Object within another Object not persisting between units Delphi - oop

Sorry if this question is a duplicate but I couldn't find any solution to my problem anywhere...
The code below shows how I'm assigning values from a listview into an object that is a property of another object:
Main Unit:
procedure TForm1.SBCadClick(Sender: TObject);
var
Procedimento: TProcedimento;
Produto: TItemProcedimento;
item: TListViewItem;
begin
...
Procedimento := TProcedimento.Create;
for item in LVItensProcedimento.Items do
begin
Produto := TItemProcedimento.Create;
Produto.PRO_ID := item.Tag;
Produto.IPR_Uso := TListItemText(item.Objects.FindDrawable('IPR_Uso'))
.Text.ToDouble;
Procedimento.AddPRC_Produtos(Produto);
Produto.DisposeOf;
end;
DM.gravaProcedimento(Procedimento); // from here we go into another unit to use its function, passing an object as a parameter
Before the command DM.gravaProcedimento(Procedimento); the produto is correctly being added to the TObjectList of TProcedimento, I can get its contents correctly with Procedimento.GetPRC_Produtos. But when I debug the next unit shown below, its getting random IDs that means its not being persisted from one unit to the other:
unit DM:
procedure TDM.gravaProcedimento(Procedimento: TProcedimento);
var
produto: TItemProcedimento;
dura: string;
begin
...
produto := TItemProcedimento.Create;
for produto in Procedimento.GetPRC_Produtos do
begin
DM.FDQ.Append;
DM.FDQ.FieldByName('PRO_ID').AsInteger := produto.PRO_ID; // here the value gets a random ID like 45684 instead of the current item ID
DM.FDQ.FieldByName('PRC_ID').AsInteger := Procedimento.PRC_ID;
DM.FDQ.FieldByName('IPR_Uso').AsFloat := produto.IPR_Uso;
DM.FDQ.Post;
end;
produto.DisposeOf;
DM.FDQ.ApplyUpdates;
DM.FDQ.Close;
end;
This is the class definition of my objects:
unit uClasses;
interface
uses
System.SysUtils, System.Types, Generics.Collections;
type
TItemProcedimento = class
private
FPRO_Nome: string;
FPRO_Tipo: integer;
FPRO_Custo: double;
FPRO_ID: integer;
FPRO_Rendimento: integer;
FPRO_Potencia: double;
FIPR_Uso: double;
procedure SetPRO_Custo(const Value: double);
procedure SetPRO_ID(const Value: integer);
procedure SetPRO_Nome(const Value: string);
procedure SetPRO_Rendimento(const Value: integer);
procedure SetPRO_Tipo(const Value: integer);
procedure SetPRO_Potencia(const Value: double);
procedure SetIPR_Uso(const Value: double);
public
constructor Create;
published
property PRO_Rendimento: integer read FPRO_Rendimento
write SetPRO_Rendimento;
property PRO_ID: integer read FPRO_ID write SetPRO_ID;
property PRO_Nome: string read FPRO_Nome write SetPRO_Nome;
property PRO_Tipo: integer read FPRO_Tipo write SetPRO_Tipo;
property PRO_Custo: double read FPRO_Custo write SetPRO_Custo;
property PRO_Potencia: double read FPRO_Potencia write SetPRO_Potencia;
property IPR_Uso: double read FIPR_Uso write SetIPR_Uso;
end;
TProcedimento = class
private
FPRC_Nome: string;
FPRC_Duracao: TDateTime;
FPRC_Preco: double;
FPRC_ID: integer;
FPRC_Consumo: double;
FPRC_Produtos: TObjectList<TItemProcedimento>;
procedure SetPRC_Consumo(const Value: double);
procedure SetPRC_Duracao(const Value: TDateTime);
procedure SetPRC_ID(const Value: integer);
procedure SetPRC_Nome(const Value: string);
procedure SetPRC_Preco(const Value: double);
public
constructor Create;
function GetPRC_Produtos: TObjectList<TItemProcedimento>;
procedure AddPRC_Produtos(const Value: TItemProcedimento);
procedure DelPRC_Produtos(const Value: TItemProcedimento);
procedure CleanPRC_Produtos;
published
property PRC_Preco: double read FPRC_Preco write SetPRC_Preco;
property PRC_Consumo: double read FPRC_Consumo write SetPRC_Consumo;
property PRC_ID: integer read FPRC_ID write SetPRC_ID;
property PRC_Nome: string read FPRC_Nome write SetPRC_Nome;
property PRC_Duracao: TDateTime read FPRC_Duracao write SetPRC_Duracao;
end;
implementation
{ TProcedimento }
procedure TProcedimento.CleanPRC_Produtos;
begin
if not Assigned(FPRC_Produtos) then
FPRC_Produtos := TObjectList<TItemProcedimento>.Create
else
FPRC_Produtos.Clear;
end;
constructor TProcedimento.Create;
begin
SetPRC_Consumo(0);
SetPRC_Duracao(0);
SetPRC_ID(0);
SetPRC_Nome('');
SetPRC_Preco(0);
end;
procedure TProcedimento.DelPRC_Produtos(const Value: TItemProcedimento);
begin
FPRC_Produtos.Delete(FPRC_Produtos.IndexOf(Value));
end;
function TProcedimento.GetPRC_Produtos: TObjectList<TItemProcedimento>;
begin
if Assigned(FPRC_Produtos) then
result := FPRC_Produtos
else
begin
CleanPRC_Produtos;
result := FPRC_Produtos;
end;
end;
procedure TProcedimento.SetPRC_Consumo(const Value: double);
begin
FPRC_Consumo := Value;
end;
procedure TProcedimento.SetPRC_Duracao(const Value: TDateTime);
begin
FPRC_Duracao := Value;
end;
procedure TProcedimento.SetPRC_ID(const Value: integer);
begin
FPRC_ID := Value;
end;
procedure TProcedimento.SetPRC_Nome(const Value: string);
begin
FPRC_Nome := Value;
end;
procedure TProcedimento.SetPRC_Preco(const Value: double);
begin
FPRC_Preco := Value;
end;
procedure TProcedimento.AddPRC_Produtos(const Value: TItemProcedimento);
begin
FPRC_Produtos.Add(Value);
end;
{ TItemProcedimento }
constructor TItemProcedimento.Create;
begin
SetPRO_Custo(0);
SetPRO_ID(0);
SetPRO_Nome('');
SetPRO_Tipo(0);
SetPRO_Rendimento(0);
end;
procedure TItemProcedimento.SetIPR_Uso(const Value: double);
begin
FIPR_Uso := Value;
end;
procedure TItemProcedimento.SetPRO_Custo(const Value: double);
begin
FPRO_Custo := Value;
end;
procedure TItemProcedimento.SetPRO_ID(const Value: integer);
begin
FPRO_ID := Value;
end;
procedure TItemProcedimento.SetPRO_Nome(const Value: string);
begin
FPRO_Nome := Value;
end;
procedure TItemProcedimento.SetPRO_Potencia(const Value: double);
begin
FPRO_Potencia := Value;
end;
procedure TItemProcedimento.SetPRO_Rendimento(const Value: integer);
begin
FPRO_Rendimento := Value;
end;
procedure TItemProcedimento.SetPRO_Tipo(const Value: integer);
begin
FPRO_Tipo := Value;
end;
end.
Any particular reason why this is happening? What am I doing wrong here?

The problem is that you are destroying the TItemProcedimento objects before gravaProcedimento() has a chance to use them.
You are calling Produto.DisposeOf() immediately after Procedimento.AddPRC_Produtos(Produto) exits, and also in gravaProcedimento(), too. DO NOT DO THAT!
AddPRC_Produtos() saves the original Produto object into a TObjectList, which takes ownership of the object (as TObjectList is set to OwnsObjects=True by default). That means the object will be destroyed automatically when it is removed from the list, which includes when the list is cleared or destroyed.
So, you need to get rid of your DisposeOf() calls completely.
Also, you need to get rid of the call to TItemProcedimento.Create in gravaProcedimento(), too. It does not belong there. All you are doing by that is creating a memory leak on non-ARC systems.
It seems you do not have a firm grasp of how Delphi object lifetimes actually work. You DO NOT need to call Create on an object variable before assigning an object instance to it. And you DO NOT need to call DisposeOf() on an object variable when you are doing using the variable, only when you are done using the object itself (which TObjectList will handle for you).
Try this instead:
procedure TForm1.SBCadClick(Sender: TObject);
var
Procedimento: TProcedimento;
Produto: TItemProcedimento;
item: TListViewItem;
begin
...
Procedimento := TProcedimento.Create;
try
for item in LVItensProcedimento.Items do
begin
Produto := TItemProcedimento.Create;
try
Produto.PRO_ID := item.Tag;
Produto.IPR_Uso := TListItemText(item.Objects.FindDrawable('IPR_Uso')).Text.ToDouble;
Procedimento.AddPRC_Produtos(Produto);
// Produto.DisposeOf; // <-- DO NOT DO THIS HERE!!!
except
Produto.DisposeOf; // <-- DO THIS HERE INSTEAD, if AddPRC_Produtos fails!!!
raise;
end;
end;
DM.gravaProcedimento(Procedimento);
finally
Procedimento.DisposeOf; // <-- ADD THIS, if needed!!!
end;
end;
procedure TDM.gravaProcedimento(Procedimento: TProcedimento);
var
produto: TItemProcedimento;
dura: string;
begin
...
// produto := TItemProcedimento.Create; // <- DO NOT DO THIS!!!
for produto in Procedimento.GetPRC_Produtos do
begin
FDQ.Append;
try
FDQ.FieldByName('PRO_ID').AsInteger := produto.PRO_ID;
FDQ.FieldByName('PRC_ID').AsInteger := Procedimento.PRC_ID;
FDQ.FieldByName('IPR_Uso').AsFloat := produto.IPR_Uso;
FDQ.Post;
except
FDQ.Cancel; // <-- ADD THIS!!!
raise;
end;
end;
// produto.DisposeOf; // <-- DO NOT DO THIS!!!
FDQ.ApplyUpdates;
FDQ.Close;
end;

You should not call Produto.DisposeOf in procedure TForm1.SBCadClick.
You are destroying the object you have just added..

Related

Invalid Pointer Operation on TObjectList.DisposeOf

Hello folks and sorry if this is a duplicate but my specific issue I haven't seen answered anywhere yet.
I have an "Invalid Pointer Operation" when I try to free an ObjectList created at runtime at the following lines:
Prods := TItemProcedimento.Create(DM.FDQ).lerProdutos;
Prods.DisposeOf; // <- Invalid Pointer Operation at 2nd iteration
So, here's my classes:
unit uItemProcedimento;
interface
[...]
type
TItemProcedimento = class
[...]
public
constructor Create(DataSet: TFDQuery);
function lerProdutos: TObjectList<TItemProcedimento>;
[...]
constructor TItemProcedimento.Create(DataSet: TFDQuery);
begin
FDataSet := DataSet;
end;
function TItemProcedimento.lerProdutos: TObjectList<TItemProcedimento>;
begin
Result := TObjectList<TItemProcedimento>.Create;
try
FDataSet.Close;
FDataSet.SQL.Clear;
FDataSet.SQL.Add('SELECT *');
FDataSet.SQL.Add('FROM Produto p');
FDataSet.SQL.Add('JOIN ItensProcedimento IP on p.PRO_ID = IP.PRO_ID');
FDataSet.SQL.Add('ORDER BY p.PRO_Nome');
FDataSet.Open;
while not FDataSet.Eof do
begin
PRO_ID := FDataSet.FieldByName('PRO_ID').AsInteger;
PRO_Rendimento := FDataSet.FieldByName('PRO_Rendimento').AsInteger;
PRO_Nome := FDataSet.FieldByName('PRO_Nome').AsString;
PRO_Tipo := FDataSet.FieldByName('PRO_Tipo').AsInteger;
PRO_Custo := FDataSet.FieldByName('PRO_Custo').AsFloat;
PRO_Potencia := FDataSet.FieldByName('PRO_Potencia').AsFloat;
IPR_Uso := FDataSet.FieldByName('IPR_Uso').AsFloat;
Result.Add(self);
FDataSet.Next;
end;
finally
FDataSet.Close;
end;
The weirdest thing about this is that I have another class with the exact same behaviour and the method works without issues. Yes I am creating the object and immediately destroying it to test if I'm destroying it correctly.
In another class I have another example with the same code, but this time it works without errors
test := TMyClass.Create(DM.FDQ).lerTeste;
test.DisposeOf;
Why? What am I doing wrong? This test code is running before the current code btw, maybe its related?
UPDATE:
By applying the changes that Remy Lebeau suggested I managed to add properly the items to the list and dispose them so this particular part of the code has no leaks. But in another part of the code I have an ObjectList leak that I have no idea on how to fix.
Inside my class I have a property that is a TObjectList property, I have a method that checks if the list is assigned, if not, it creates it and returns it to whoever is calling the list.
[...]
type
TProcedimento = class
private
[...]
FPRC_Produtos: TObjectList<TItemProcedimento>;
public
[...]
function getPRC_Produtos: TObjectList<TItemProcedimento>;
function criaProcedimentos: TObjectList<TProcedimento>;
[...]
function TProcedimento.GetPRC_Produtos: TObjectList<TItemProcedimento>;
begin
if not Assigned(FPRC_Produtos) then
FPRC_Produtos:= TObjectList<TItemProcedimento>.Create;
result := FPRC_Produtos;
end;
function TProcedimento.criaProcedimentos: TObjectList<TProcedimento>;
var
IPR: TItemProcedimento;
Procedimento: TProcedimento;
ds: TFDQuery;
begin
result := TObjectList<TProcedimento>.Create;
ds := TFDQuery.Create(nil);
ds.Connection := FDataSet.Connection;
IPR := TItemProcedimento.Create(ds);
try
FDataSet.Close;
FDataSet.Open('SELECT * FROM Procedimento');
while not FDataSet.Eof do
begin
Procedimento := TProcedimento.Create(FDataSet);
Procedimento.PRC_ID := FDataSet.FieldByName('PRC_ID').AsInteger;
Procedimento.PRC_Nome := FDataSet.FieldByName('PRC_Nome').AsString;
Procedimento.PRC_Duracao := FDataSet.FieldByName('PRC_Duracao')
.AsDateTime;
Procedimento.PRC_Preco := FDataSet.FieldByName('PRC_Preco').AsCurrency;
Procedimento.PRC_Custo := FDataSet.FieldByName('PRC_Custo').AsCurrency;
Procedimento.PRC_Consumo := FDataSet.FieldByName('PRC_Consumo').AsFloat;
Procedimento.FPRC_Produtos := IPR.getItensProcedimento(FPRC_ID);
result.Add(Procedimento);
FDataSet.Next;
end;
finally
FDataSet.Close;
IPR.DisposeOf;
ds.DisposeOf;
end;
end;
I then use this property in a for-in loop to feed a list with the procs in my database
procedure TKBForm1.CarregaProcedimento;
var
Procedimento: TProcedimento;
Procs: TObjectList<TProcedimento>;
[...]
begin
Procs := TProcedimento.Create(DM.FDQ).criaProcedimentos;
try
LV_Procedimento.Items.Clear;
LV_Procedimento.BeginUpdate;
for Procedimento in Procs do
begin
with LV_Procedimento.Items.Add do
[...]
finally
Procs.DisposeOf;
Procedimento.GetPRC_Produtos.DisposeOf;
end;
end;
But there's still leaks happening after this part runs:
73 - 88 bytes: TProcedimento x 1, TItemProcedimento x 2
How do I fix this?

How to fix Access Violation at address in Delphi

I'm new to delphi and am trying to start OOP. However I get an access violation when using public property to set a private field.
type
User = class;
TData = class
private
CurrUser: User;
Connection: TFDConnection;
Query: TFDQuery;
procedure SetUser(newUser: User);
procedure SetConnection(newConn: TFDConnection);
procedure SetQuery(newQry: TFDQuery);
public
property CUser: User read CurrUser write SetUser;
property Conn: TFDConnection read Connection write SetConnection;
property Qry: TFDQuery read Query write SetQuery;
class procedure Login(uID: integer); static;
class procedure Logout(uID: integer); static;
class procedure ExitApp(); static;
end;
implementation
{$R *.fmx}
procedure TData.SetUser(newUser: User);
begin
CurrUser := newUser;
end;
procedure TData.SetConnection(newConn: TFDConnection);
begin
Connection := newConn;
end;
procedure TData.SetQuery(newQry: TFDQuery);
begin
Query := newQry;
end;
I expect to be able to set the Connection using that property however it gives me the access violation with any code that uses the property write:
TData.Conn.LoginPrompt := False;
TData.Conn.Connected := True;
var
TData: frmData.TData;
LoginForm: TLoginForm;
ErrorCount : integer;
implementation
{$R *.fmx}
procedure TLoginForm.ExitAppButtonClick(Sender: TObject);
begin
TData.ExitApp;
end;
procedure TLoginForm.LoginButtonClick(Sender: TObject);
var
companyPath : string;
nurseID : integer;
begin
if(UsernameInput.Text = '') or (PasswordInput.Text = '') or (PincodeInput.Text = '') then
begin
ShowMessage('Please enter your login details.');
Exit;
end;
try
TData.Conn := TFDConnection.Create(nil);
TData.Conn.Params.DriverID := 'MSAcc';
TData.Conn.Params.Database := 'D:\PulseDB\AlfaPersonnel\Pulse.mdb';
TData.Conn.LoginPrompt := False;
TData.Conn.Connected := True;
if(TData.Conn.Connected <> True) then
begin
ShowMessage('Could not connect, try again');
Exit;
end
else //When Connection
begin
TData.Qry := TFDQuery.Create(TData.Conn);
try
TData.Qry.Connection := TData.Conn;
TData.Qry.SQL.Text := 'SELECT * FROM NurseLogin WHERE Username=:uname AND Password=:pword AND PinCode=:pin;';
TData.Qry.Params.ParamByName('uname').AsString := UsernameInput.Text;
TData.Qry.Params.ParamByName('pword').AsString := PasswordInput.Text;
TData.Qry.Params.ParamByName('pin').AsString := PincodeInput.Text;
TData.Qry.Active := True;
if TData.Qry.RecordCount = 0 then ShowMessage('Details not recognised.')
else if TData.Qry.RecordCount = 1 then
begin
if TData.Qry.FieldByName('IsActive').AsBoolean then //If the user is active
begin
try
//Connect to the path
companyPath := TData.Qry.FieldByName('CompanyName').AsString;
TData.Conn.Params.Database := 'D\PulseDB\' + companyPath + '\Pulse.mdb';
TData.Conn.Connected := True;
ShowMessage('Connected to ' + companyPath);
finally
end;
end;
end;
finally
end;
end;
finally
end;
end;
You don't ever create an instance of your TData class. At some point you need to write:
TData := frmData.TData.Create;
Which is how you instantiate an instance. And you need to destroy it when you are finished also. Like this:
TData.Free;
That you did not instantiate an instance is the explanation for your access violation.
Some other issues:
Use the T prefix for types. Your variable should be named Data rather than TData.
Don't use global variables if at all possible.

How do procedures work with object types in PL/SQL?

I don't fully understand the purpose of procedures for PL/SQL object types. From reading online, the impression I got was that functions should not modify the data and should only return a value, instead procedures should be used, however it appears that for object types, changes in a procedure don't propagate outside the local context:
CREATE OR REPLACE TYPE TestType FORCE
AS OBJECT
(
TestValue NUMBER
, CONSTRUCTOR FUNCTION TestType
RETURN SELF AS RESULT
, MEMBER PROCEDURE IncrementValueAsProcedure
, MEMBER FUNCTION IncrementValueAsFunction
RETURN TestType
)
/
CREATE OR REPLACE TYPE BODY TestType
AS
CONSTRUCTOR FUNCTION TestType
RETURN SELF AS RESULT
IS
BEGIN
SELF.TestValue := 0;
RETURN;
END;
MEMBER PROCEDURE IncrementValueAsProcedure
IS
MyType TestType := SELF;
BEGIN
MyType.TestValue := TestValue + 1;
END;
MEMBER FUNCTION IncrementValueAsFunction
RETURN TestType
IS
MyType TestType := SELF;
BEGIN
MyType.TestValue := TestValue + 1;
RETURN MyType;
END;
END;
/
DECLARE
MyTest TestType;
BEGIN
MyTest := TestType();
DBMS_OUTPUT.PUT_LINE(MyTest.TestValue);
MyTest.IncrementValueAsProcedure();
DBMS_OUTPUT.PUT_LINE(MyTest.TestValue);
MyTest := MyTest.IncrementValueAsFunction();
DBMS_OUTPUT.PUT_LINE(MyTest.TestValue);
END;
This gives the output:
0
0
1
So the change in the update procedure hasn't been picked up. What am I doing wrong?
Oh, worked this out.
MEMBER PROCEDURE IncrementValueAsProcedure
IS
MyType TestType := SELF;
BEGIN
MyType.TestValue := TestValue + 1;
END;
This creates a copy of the current object and updates it. The following works as expected:
MEMBER PROCEDURE IncrementValueAsProcedure
IS
BEGIN
TestValue := TestValue + 1;
END;

Store and read the Objects in/from TObjectList

TPoint = Class
private
FX: double;
FY: double;
public
constructor Create(X,Y:double);
destructor Destroy; override;
property X: double read FX write FX;
property Y: double read FY write FY;
end;
TLine= Class(TObjectList)
private
function GetItem(Index: Integer): TPoint;
procedure SetItem(Index: Integer; const Value: TPoint);
public
constructor Create;
destructor Destroy; override;
procedure Add(APoint:TPoint);
property Items[Index: Integer]: TPoint read GetItem write SetItem; default;
end;
TLineStorage= Class(TObjectList)
private
function GetItem(Index: Integer): TLine;
procedure SetItem(Index: Integer; const Value: TLine);
public
constructor Create;
destructor Destroy; override;
procedure Add(ALinie:TLine);
property Items[Index: Integer]: TLine read GetItem write SetItem; default;
end;
TStorage= Class(TObjectList)
private
function GetItem(Index: Integer): TLineStorage;
procedure SetItem(Index: Integer; const Value: TLineStorage);
public
constructor Create;
destructor Destroy; override;
procedure Add(ALinieStorage:TLineStorage);
property Items[Index: Integer]: TLineStorage read GetItem write SetItem; default;
end;
TMeasuring= Class
private
FLine: TLine;
FLineStorage: TLineStorage;
FStorage: TStorage;
public
constructor Create;
destructor Destroy; override;
procedure DoMeasuring;
end;
{ TMeasuring }
constructor TMeasuring.Create;
begin
inherited;
FLineStorage:= TLineStorage.Create;
FLineStorage.OwnsObjects:= true;
FLine:= TLine.Create;
FLine.OwnsObjects:= true;
FStorage:= TStorage.Create;
FStorage.OwnsObjects:= true;
end;
destructor TMeasuring.Destroy;
begin
FLineStorage.Free;
FLine.Free;
FStorage.Free;
inherited;
end;
procedure TMeasuring.DoMeasuring;
var i,j: integer; X,Y: double;
begin
for j:= 0 to 2 do // Lines
begin
for i:= 0 to 5 do // Points
begin
X:= 1+ random(100);
Y:= 1+ random(100);
FLine.Add(TPoint.Create(X,Y)); // 1... X Points
end;
FLineStorage.Add(FLine); // 3 x Linie
FLine.Clear; // for new measuring !!! if not-> it works !!!
end;
FStorage.Add(FLineStorage); // save
for i:= 0 to FStorage.Count-1 do
begin
X:= FStorage.Items[i].Items[i].Items[i].X; // it doesn't work...
ShowMessage(FloatToStr(X));
end;
end;
I work with Delphi 7 and I try to store and display the results of a measurement. But if I try to read the X / Y points I get a range exception. If I comment FLine.Clear; off, it works. How do you get around this problem?
In addition, the program comes out with a message that relates to the storage.
All of the GetItem- functions look like:
function TLine.GetItem(Index: Integer): TPoint;
begin
result:= TPoint(inherited Items[Index]);
end;
Thank you in advance.
You should create your FLine in DoMeasuring
procedure TMeasuring.DoMeasuring;
var i,j: integer; X,Y: double;
FLine : TLine;
begin
for j:= 0 to 2 do // Lines
begin
FLine := TLine.create;
for i:= 0 to 5 do // Points
begin
X:= 1+ random(100);
Y:= 1+ random(100);
FLine.Add(TPoint.Create(X,Y)); // 1... X Points
end;
FLineStorage.Add(FLine); // 3 x Linie
//FLine.Clear; // for new measuring !!! if not-> it works !!!
end;
FStorage.Add(FLineStorage); // save
for i:= 0 to FStorage.Count-1 do
begin
X:= FStorage.Items[i].Items[i].Items[i].X; // it doesn't work...
ShowMessage(FloatToStr(X));
end;
end;

RemObjects PascalScript How to get the value of the variable after compilation?

RemObjects PascalScript.
How to get the value of the variable after compilation?
var a,b,c: integer;
begin
a := 5;
b := 6;
c := a+b;
end;
cc := IntTostr(????c????);
You have two options:
You can register a function with
Sender.AddDelphiFunction('procedure MyOwnFunction(Data: string)');
and
Exec := TPSExec.Create; // Create an instance of the executer.
Exec.RegisterDelphiFunction(#MyOwnFunction, 'MYOWNFUNCTION', cdRegister);
and then call it from within your script.
Alternatively, you can define your script as a function and set the Result. Then you can retrieve it with
TestFunc := TTestFunction(Exec.GetProcAsMethodN('Test'));
Both methods are demonstrated in this example:
program sample8;
uses
uPSCompiler,
uPSRuntime,
uPSUtils,
Dialogs;
procedure MyOwnFunction(const Data: string);
begin
// Do something with Data
ShowMessage(Data);
end;
{$IFDEF UNICODE}
function ScriptOnExportCheck(Sender: TPSPascalCompiler; Proc: TPSInternalProcedure; const ProcDecl: AnsiString): Boolean;
{$ELSE}
function ScriptOnExportCheck(Sender: TPSPascalCompiler; Proc: TPSInternalProcedure; const ProcDecl: string): Boolean;
{$ENDIF}
{
The OnExportCheck callback function is called for each function in the script
(Also for the main proc, with '!MAIN' as a Proc^.Name). ProcDecl contains the
result type and parameter types of a function using this format:
ProcDecl: ResultType + ' ' + Parameter1 + ' ' + Parameter2 + ' '+Parameter3 + .....
Parameter: ParameterType+TypeName
ParameterType is # for a normal parameter and ! for a var parameter.
A result type of 0 means no result.
}
begin
if Proc.Name = 'TEST' then // Check if the proc is the Test proc we want.
begin
if not ExportCheck(Sender, Proc, {$IFDEF UNICODE}[btUnicodeString, btUnicodeString]{$ELSE}[btString, btString]{$ENDIF}, [pmIn]) then // Check if the proc has the correct params.
begin
{ Something is wrong, so cause an error. }
Sender.MakeError('', ecTypeMismatch, '');
Result := False;
Exit;
end;
Result := True;
end else Result := True;
end;
{$IFDEF UNICODE}
function ScriptOnUses(Sender: TPSPascalCompiler; const Name: AnsiString): Boolean;
{$ELSE}
function ScriptOnUses(Sender: TPSPascalCompiler; const Name: string): Boolean;
{$ENDIF}
{ the OnUses callback function is called for each "uses" in the script.
It's always called with the parameter 'SYSTEM' at the top of the script.
For example: uses ii1, ii2;
This will call this function 3 times. First with 'SYSTEM' then 'II1' and then 'II2'.
}
begin
if Name = 'SYSTEM' then
begin
Sender.AddDelphiFunction('procedure MyOwnFunction(Data: string)');
{ This will register the function to the script engine. Now it can be used from within the script. }
Result := True;
end else
Result := False;
end;
type
TTestFunction = function (const s: string): string of object;
// Header of the test function, added of object.
procedure ExecuteScript(const Script: string);
var
Compiler: TPSPascalCompiler;
{ TPSPascalCompiler is the compiler part of the scriptengine. This will
translate a Pascal script into a compiled form the executer understands. }
Exec: TPSExec;
{ TPSExec is the executer part of the scriptengine. It uses the output of
the compiler to run a script. }
{$IFDEF UNICODE}Data: AnsiString;{$ELSE}Data: string;{$ENDIF}
TestFunc: TTestFunction;
begin
Compiler := TPSPascalCompiler.Create; // create an instance of the compiler.
Compiler.OnUses := ScriptOnUses; // assign the OnUses event.
Compiler.OnExportCheck := ScriptOnExportCheck; // Assign the onExportCheck event.
Compiler.AllowNoBegin := True;
Compiler.AllowNoEnd := True; // AllowNoBegin and AllowNoEnd allows it that begin and end are not required in a script.
if not Compiler.Compile(Script) then // Compile the Pascal script into bytecode.
begin
Compiler.Free;
// You could raise an exception here.
Exit;
end;
Compiler.GetOutput(Data); // Save the output of the compiler in the string Data.
Compiler.Free; // After compiling the script, there is no need for the compiler anymore.
Exec := TPSExec.Create; // Create an instance of the executer.
Exec.RegisterDelphiFunction(#MyOwnFunction, 'MYOWNFUNCTION', cdRegister);
if not Exec.LoadData(Data) then // Load the data from the Data string.
begin
{ For some reason the script could not be loaded. This is usually the case when a
library that has been used at compile time isn't registered at runtime. }
Exec.Free;
// You could raise an exception here.
Exit;
end;
TestFunc := TTestFunction(Exec.GetProcAsMethodN('Test'));
if #TestFunc <> nil then
ShowMessage('Result from TestFunc(''test indata''): '+TestFunc('test indata'));
Exec.Free; // Free the executer.
end;
const
Script = 'function test(s: string): string; begin MyOwnFunction(''Test Called with param: ''+s); Result := ''Test Result: ''+s; end;';
begin
ExecuteScript(Script);
end.