Lazarus Pascal -- Class methods can't acces to private members - oop

I am having an issue with Pascal-Lazarus (Linux):
The class methods can't acces the members. It isn't a compiler mistake, but a runtime error. (SIGSEV)
For more informations: i am using Linux with the newest version (16_4) and Lazarus Pascal (16.0). My system type is x86_64
the code:
unit compiler_code;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls;
type
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
TLine = class
public //public methods
procedure setLine(i: string); //setter for the line.
procedure compileLine(); //just runs the different methods of the class
private //private members
var m_string : string;
var m_stringLength : integer;
private //private methods
function deleteBlanks (i: string) : string;
procedure getStringLength();
end;
var Form1: TForm1;
var Zeile: TLine;
implementation
{ TForm1 }
procedure TForm1.Button1Click(Sender: TObject);
begin
Zeile.setLine ('Hallo');
Zeile.compileLine ();
end;
/////////////////////////Implementation of the Methods of TLine
procedure TLine.setLine(i: string); //Setter --> no getter needed.
begin
showmessage (i);
showmessage (m_string); //here is where the issue comes up
//m_string:= i;
end;
procedure TLine.compileLine(); //runs all of the Methods.
begin
getStringLength (); // gets the length of the String-input
m_string := deleteBLanks(m_string); //deletes all of the blank space inside the String.
end;
function TLine.deleteBlanks (i: string) : string; //blankSpace-Deleter
var isText : boolean = false; //switch, to check, if the momentary Character is text or not.
var counter: integer = 0; //counts the number of cycles of the loop
begin
while ((counter < m_stringLength) and (not (m_stringLength = 0))) do //the 'Loop'
begin
if ((m_string[counter] = ' ') and (not(isText))) then
begin
delete (m_string, counter, 1); //deletes the blank position
dec (counter); //because there is a position less in the string now.
getStringLength(); //regenerates the length of the String;
end;
end;
end;
procedure TLine.getStringLength ();
begin
m_stringLength:= length (m_string); //gets the Length of the String input.
end;
{$R *.lfm}
end.

The explanation is, presumably, that you simply have not created an instance of the class TLine. Nowhere do you assign to Zeile and so it remains at its default value of nil.
You need to instantiate an instance
Zeile := TLine.Create;
You must do this before you attempt to reference Zeile. When you are done with the instance, destroy it:
Zeile.Free;

Related

Input and output pipe in Lazarus TProcess

I would like to make a terminal with a Lazarus GUI application. But I'm in trouble. And I hope someone can help me, please.
Question1: The Chinese and other special chars cannot display normally, I would like to know how to fix this problem.
(code)Class of the thread and "run" button on click event
screenshot
Question2: I want to know how to input some command into the console. I tried to start a Windows cmd, and use "winver" command. But when I click the button, nothing happened.
The send command button
Winver is not console but a GUI program. To run a program with output into memo, use the following code, which retrieves version using the cmd.exe "ver" command. You can try to use this template for the first question too.
unit mainprocesstomemo;
{$mode delphi}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, Process, Pipes;
Type
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
public
procedure ProcessEvent(Sender,Context : TObject;Status:TRunCommandEventCode;const Message:string);
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TProcessMemo }
Type
TProcessToMemo = class(TProcess)
public
fmemo : Tmemo;
bytesprocessed : integer;
fstringsadded : integer;
function ReadInputStream(p:TInputPipeStream;var BytesRead:integer;var DataLength:integer;var Data:string;MaxLoops:integer=10):boolean;override;
end;
function RunCommandMemo(const exename:TProcessString;const commands:array of TProcessString;out outputstring:string; Options : TProcessOptions = [];SWOptions:TShowWindowOptions=swoNone;memo:TMemo=nil;runrefresh : TOnRunCommandEvent=nil ):boolean;
Var
p : TProcessToMemo;
i,
exitstatus : integer;
ErrorString : String;
begin
p:=TProcessToMemo.create(nil);
if Options<>[] then
P.Options:=Options - [poRunSuspended,poWaitOnExit];
p.options:=p.options+[poRunIdle];
P.ShowWindow:=SwOptions;
p.Executable:=exename;
if high(commands)>=0 then
for i:=low(commands) to high(commands) do
p.Parameters.add(commands[i]);
p.fmemo:=memo;
p.OnRunCommandEvent:=runrefresh;
try
result:=p.RunCommandLoop(outputstring,errorstring,exitstatus)=0;
finally
p.free;
end;
if exitstatus<>0 then result:=false;
end;
{ TForm1 }
procedure TForm1.Button1Click(Sender: TObject);
var s : string;
begin
//RunCommandMemo('testit',[],s,[],swonone,memo1,ProcessEvent);
RunCommandMemo('cmd.exe',['/w','/c','ver'],s,[],swonone,memo1,ProcessEvent);
end;
procedure TForm1.ProcessEvent(Sender, Context: TObject;
Status: TRunCommandEventCode; const Message: string);
begin
if status in [RunCommandIdle, RunCommandFinished] then
begin
if status =RunCommandFinished then
begin
memo1.lines.add(' process finished');
end;
if tprocesstomemo(sender).fstringsadded>0 then
begin
tprocesstomemo(sender).fstringsadded:=0;
// memo1.lines.add('Handle:'+inttostr(tprocesstomemo(sender).ProcessHandle));
memo1.refresh;
end;
sleep(10);
application.ProcessMessages;
end;
end;
{ TProcessToMemo }
function TProcessToMemo.ReadInputStream(p:TInputPipeStream;var BytesRead:integer;var DataLength:integer;var Data:string;MaxLoops:integer=10):boolean;
var lfpos : integer;
crcorrectedpos:integer;
stradded : integer;
newstr : string;
begin
Result:=inherited ReadInputStream(p, BytesRead, DataLength, data, MaxLoops);
if (result) and (bytesread>bytesprocessed)then
begin
stradded:=0;
lfpos:=pos(#10,data,bytesprocessed+1);
while (lfpos<>0) and (lfpos<=bytesread) do
begin
crcorrectedpos:=lfpos;
if (crcorrectedpos>0) and (data[crcorrectedpos-1]=#13) then
dec(crcorrectedpos);
newstr:=copy(data,bytesprocessed+1,crcorrectedpos-bytesprocessed-1);
fmemo.lines.add(newstr);
inc(stradded);
bytesprocessed:=lfpos;
lfpos:=pos(#10,data,bytesprocessed+1);
end;
inc(fstringsadded,stradded); // check idle event.
end;
end;
end.
I don't know minecraft server, and many external programs might do weird things to the console. But a simple combination of programs to test with is here http://www.stack.nl/~marcov/files/processmemodemo.zip

Using Object Orientated subclasses in a separate form

I have created a factory unit that contains multiple subclasses for different functions.
FACTORY UNIT
//parent
type
TfactoryU = class(Tobject)
public
constructor create;
end;
//subclass 1
TFormPosition = class (TfactoryU)
private
fFormName:tform;
public
constructor create (formName:tform);
procedure centerForm(frm:tform);
end;
implementation
{ TfactoryU }
constructor TFormPosition.Create(formName:tform);
begin
Inherited Create;
fFormName:=formname;
end;
procedure TFormPosition.centerForm(frm:tform);
begin
frm.Left := (Screen.Width - frm.Width) div 2;
frm.Top := (Screen.Height - frm.Height) div 2;
end;
constructor TfactoryU.create;
begin
end;
However, I do not know how to call the subclass procedure from a different unit.
MAIN UNIT
procedure TfrmMERCH.FormActivate(Sender: TObject);
var
objfactoryU:TfactoryU;
begin
objfactoryU:=tformposition.create(frmmerch);
objfactoryU.centerForm(frmmerch);
The calling of the procedure centerForm is underlined in red.
centerForm() is not a member of TfactoryU, that is why you get an error when trying to call it via a TfactoryU variable. You need to use a type-cast to reach it, eg:
procedure TfrmMERCH.FormActivate(Sender: TObject);
var
objfactoryU: TfactoryU;
begin
objfactoryU := tformposition.create(frmmerch);
tformposition(objfactoryU).centerForm(frmmerch);
However, since both the declaration of objfactoryU and the call to the centerForm() method are in the same procedure, you should just change the declaration instead:
procedure TfrmMERCH.FormActivate(Sender: TObject);
var
objfactoryU: tformposition;
begin
objfactoryU := tformposition.create(frmmerch);
objfactoryU.centerForm(frmmerch);

Generic mechanism for instantiating distinct types in Delphi

I'm trying to use generics to 'genericize' a var that instantiates network transports of different types. I'm not sure if the "generic=no RTTI" rule would invalidate the approach or not, as I'm not yet up to speed with generics.
I've read this post:
What is the correct way to structure this generic object creation , which states the following in the question:
One other thing I would like to do if possible, is to change two
creations:
LAdapter := TSQLiteNativeConnectionAdapter.Create(LFilename)
LAdapter := TFireDacConnectionAdapter.Create(FDatabaseLink.FConnection as TFDConnection, FDatabaseLink.OwnedComponent)
to use an abstract "GetAdapterClass" type function in the parent
TModelDatabaseConnection and just declare the class of adapter in the
child to do something like:
LAdapter := GetAdapterClass.Create...
This is exactly what I would like to do as well. So if you can picture this:
type
TTransport<T> = class(TComponent)
private
...
function GetTransport: TTransport;
procedure SetTransport(AValue: TTransport);
...
public
...
property Transport: TTransport read GetTransport write SetTransport;
...
end;
TTCPIPTransport = class(TTransport<T>)
private
function GetSocket(Index: Integer): String;
procedure SetSocket(Index: Integer; AValue: String);
public
property Socket[Index: Integer]: String read GetSocket write SetSocket;
end;
TServiceTransport = class(TTransport<T>)
private
function GetServiceName: String;
procedure SetServiceName(AValue: String);
public
property ServiceName: String read GetServiceName write SetServiceName;
end;
TISAPITransport = class(TServiceTransport<T>);
THTTPSysTransport = class(TServiceTransport<T>)
private
function GetURL(Index: Integer): String;
procedure SetURL(Index: Integer; AValue: String);
public
property URL[Index: Integer]: read GetURL write SetURL;
end;
etc.
The idea is to create a base class that has all fields/properties/methods that are common to all transports, then have intermediate classes that contain fields/methods/properties that are common only to a certain subset of transports, then have the final version of each transport be specific to the type.
So when I call:
var
trans: TTransport<T> // or TTransport<TTCPIPTransport> etc.
begin
trans := TTransport<TTCPIPTransport>.Create(AOwner,....);
trans.Transport.Socket[0] := '127.0.0.1:8523';
OR
trans := TTransport<TISAPITransport>.Create(AOwner,...);
trans.Transport.ServiceName = 'Foo';
...
etc.
end;
or perhaps even more generic then that, but have each instance of trans - without typecasting - have properties/fields/methods that are specific to the subclass automagically show up.
This way I can have a config screen that allows an administrator to select the type of transport say in a combo box, the have that variable value set the type inside the <> in code, and one set of code handles creation of the object by it's type.
Is this possible using generics?
Here is my first (feeble) attempt at a class factory, never done this before. It works partially (generates the correct class) but isn't accessible as a distinct subclass of the base class without typecasting, which defeats the purpose. Please see inline comments
TWSTransport = class(TComponent)
...
public
constructor Create(AOwner: TComponent); virtual;
....
end;
TWSTransportClass = Class of TWSTransport;
TWSTCPIPTransportClass = class of TWSTCPIPTransport;
TWSHTTPSysTransport = class(TWSServiceTransport);
TWSServiceTransport = class(TWSTransport);
TWSTransportStringConversion = class(TWSTransport);
TWSTransportStreamFormat = class(TWSTransportStringConversion);
TTransportFactory = class(TClassList)
private
function GetTransport(Index: TWSTransportClass; AOwner: TkbmMWServer): TWSTransportClass;
public
procedure RegisterTransportClass(ATransportClass: TWSTransportClass);
property Transport[Index: TWSTransportClass; AOwner: TkbmMWServer]: TWSTransportClass read GetTransport;
end;
function TTransportFactory.GetTransport(Index: TWSTransportClass; AOwner: TkbmMWServer): TWSTransportClass;
begin
if IndexOf(Index) > -1 then
Result := TWSTransportClass(Items[IndexOf(Index)])
else
Result := TWSTransportClass(Index.Create(AOwner));
end;
procedure TTransportFactory.RegisterTransportClass(ATransportClass: TWSTransportClass);
var
index: Integer;
begin
// is the transport registered?
index := IndexOf(ATransportClass);
if index < 0 then
// the transport is not registered, add it to the list
Add(ATransportClass);
end;
initialization
factory := TTransportFactory.Create;
factory.RegisterTransportClass(TWSHTTPSysTransport);
factory.RegisterTransportClass(TWSISAPIRESTTransport);
factory.RegisterTransportClass(TWSTCPIPTransport);
finalization
FreeAndNil(factory);
end.
Here's how I tested it:
procedure TForm4.FormCreate(Sender: TObject);
var
//trans: TWSTCPIPTransport; // this doesn't work
trans: TWSTransport; // this works
begin
trans := factory.Transport[TWSTCPIPTransport,Self];
showmessage(trans.classname); // this shows the correct classname - TWSTCPIPTransport
trans.AddSocket('127.0.0.1:80'); // the compiler gives an error here because this call is specific to a subclass of TWSTransport, TWSTCPIPTransport.
end;
So I'm still missing something... anyone see the mistake?

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.