Add a Data Pointer to TIdTCPServer and TIdCustomTCPServer - delphi

I would like to add a Data Pointer to the TIdTCPServer and I would like to have it also in the TIdCustomTCPServer. I'm not good in overriding, etc. so that's what I have so far:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, IdContext, IdBaseComponent, IdComponent,
IdCustomTCPServer, IdTCPServer, Vcl.StdCtrls;
type
TIdTcpServer = class(IdTcpServer.TIdTcpServer)
public
Data : Pointer;
end;
type
TForm1 = class(TForm)
IdTCPServer1: TIdTCPServer;
Button1: TButton;
procedure IdTCPServer1Connect(AContext: TIdContext);
procedure IdTCPServer1Disconnect(AContext: TIdContext);
procedure IdTCPServer1Execute(AContext: TIdContext);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
IdTCPServer1.Data := TObject (12345); // Just a test to fill the Data Pointer;
end;
procedure TForm1.IdTCPServer1Connect(AContext: TIdContext);
var
ParentServer : TIdCustomTCPServer;
MyData : Integer;
begin
//
ParentServer := TIdServerContext(AContext).Server;
// MyData := Integer(ParentServer.Data);
end;
procedure TForm1.IdTCPServer1Disconnect(AContext: TIdContext);
begin
//
end;
procedure TForm1.IdTCPServer1Execute(AContext: TIdContext);
begin
//
end;
end.
How could I do this to get the Data Pointer back to any of the OnConnect/OnDisconnect/etc ?

There is no Data property in http://www.indyproject.org/docsite/html/!!MEMBEROVERVIEW_TIdTCPServer.html - are you sure your code compiles and works ?
Well, if there is such a property then just cast the variable back.
procedure TForm1.IdTCPServer1Connect(AContext: TIdContext);
var
ParentServer : TIdCustomTCPServer;
MyData : Integer;
begin
//
ParentServer := TIdServerContext(AContext).Server;
MyData := Integer( (ParentServer as TIdTcpServer).Data);
end;
If there is not - then you have two options. The one is subclassing - adding the property in your class, and second is adding some outside data storage.
Unit IDWithData;
interface uses IdTCPServer;
type TIdTcpServer = class( IdTCPServer.TIdTcpServer )
public
var Data: Integer;
end;
implementation
end.
Add this unit at LAST position in the TForm1's unit INTERFACE/USES list and voila! the server now was - invisible to the IDE - replaced with your subclassed one, which have the new Data field, thus the typecast above would work using this new but intentionally same-named type.
Of course, if you wish, you may just go full throttle: add your own name for new class, make new runtime and designtime packages, add then install your new server to IDE VCL Palette and replacing them on all your forms. Another "proper" solution would be forking INDY sources, adding the DATA variable to the very vanilla TIdCustomTCPServer type and then keep maintainging your own forked branch of INDY.
More conservative approach would be just creating a global variable of type TDictionary< TIdCustomTCPServer,Integer > - http://docwiki.embarcadero.com/CodeExamples/XE4/en/Generics_Collections_TDictionary_(Delphi)
Then it would become like this:
procedure TForm1.Button1Click(Sender: TObject);
begin
GlobalServerDictionary.AddOrSetValue( IdTCPServer1, 12345 );
end;
procedure TForm1.IdTCPServer1Connect(AContext: TIdContext);
var
ParentServer : TIdCustomTCPServer;
MyData : Integer;
begin
ParentServer := TIdServerContext(AContext).Server;
MyData := GlobalServerDictionary.Items[ ParentServer ];
end;

Related

Delphi error while returning TList

I have made a very simple application but I have an issue that I really cannot understand. Look at this basic code:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, generics.collections, Vcl.StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
test: TList<integer>;
aList: TList<integer>;
public
{ Public declarations }
function testGenerics: TList<integer>;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
test := testGenerics;
test.Sort;
showmessage(test[0].tostring);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
test := TList<integer>.Create;
aList := TList<integer>.Create;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
aList.Free;
test.Free;
end;
function TForm1.testGenerics: TList<integer>;
begin
aList.Add(4);
result := aList;
end;
end.
Basically when the Form opens I am going to create test and aList and then when I press the button the function testGenerics is called. Why do I have the Invalid pointer operation error?
I really cannot understand since I am creating and destroying the objects (I guess) properly. This code instead works fine:
function TForm1.testGenerics: TList<integer>;
begin
Result := TList<integer>.Create;
Result.Add(4);
end;
In this case I am returning an instance of TList<integer> but also in the case above I am returning an instance of aList (which is a TList).
If I'm correct in the first case test := testGenerics is like test := aList (because I am returning aList in fact) so I am going to give test the same reference as aList. Am I correct?
In the first example, whenever you call testGenerics(), you are re-assigning test to point at the aList object. You are losing track of the original test object created in the OnCreate event, so it is leaked. And then in the OnDestroy event, when you call test.Free, it crashes because you already freed the aList object beforehand, so you are trying to free the same object a second time, which is an invalid operation.
In the second example, you are still leaking the original test object (and every TList you allocate and assign to test, except for the last one), but you are not re-assigning test to point at the aList object anymore, so there is no crash in the OnDestroy event because both variables are pointing at separate objects.
What are you trying to accomplish in the first place? Returning objects in this manner is not good practice. Nor does it make sense to call Sort() on 1-element lists.
If you are trying to populate test with multiple values over time, you should pass test as an input parameter to testGenerics() (or just let testGenerics() access test directly via Self), don't use the return value at all.
And in any case, get rid of your aList private member, as you are not doing anything with it anyway.
Try this:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, generics.collections, Vcl.StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
test: TList<integer>;
public
{ Public declarations }
procedure testGenerics(aList: TList<integer>);
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
testGenerics(test);
test.Sort;
ShowMessage(test[0].tostring);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
test := TList<integer>.Create;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
test.Free;
end;
procedure TForm1.testGenerics(aList: TList<integer>);
begin
// FYI, a better way to exercise Sort()
// would be to use RandomRange() instead
// of a hard-coded number...
aList.Add(4);
end;
end.

Reference counted object within a record not destroyed when record goes out of scope

I have a record that contains what I believe is a pointer to a reference counted object. I would expect that if I create the reference counted object within the record that when the record goes out of scope the reference count of the object would fall to zero, and the object would be destroyed. But this does not seem to be that case. Here is sample minimum code. My form happens to have some panels and a memo, but only the TButton (and specifically Button1Click) is important.
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls;
type
TUserData = class( TInterfacedObject )
public
AData : integer;
constructor Create;
destructor Destroy; override;
end;
TTestRec = Record
AField : integer;
UserData : TUserData;
End;
TForm4 = class(TForm)
Panel1: TPanel;
Panel2: TPanel;
Panel3: TPanel;
Memo1: TMemo;
Button1: TButton;
procedure FormShow(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form4: TForm4;
implementation
{$R *.dfm}
procedure TForm4.Button1Click(Sender: TObject);
var
iRec : TTestRec;
begin
iRec.UserData := TUserData.Create;
// stop too much optimisation
Button1.Caption := IntToStr( iRec.UserData.AData );
end; // I would expect TTestRec and hence TTestRec.UserData to go out of scope here
procedure TForm4.FormShow(Sender: TObject);
begin
// show leaks on exit
ReportMemoryLeaksOnShutdown := TRUE;
end;
{ TUserData }
constructor TUserData.Create;
begin
inherited Create;
AData := 4;
end;
destructor TUserData.Destroy;
begin
inherited;
end;
end.
I confess I don't really understand how reference counting works in detail, although I do understand the principle. What am I missing? Am I expecting too much and if so, is there any way to avoid memory leaks, not in this specific case (where obviously I could destroy UserData on exit) but in general, since records do not support destructors.
Automatic reference counting is performed through interface variables. You don't have any. Instead of a variable of type TUserData you need a variable that is an interface.
You could use IInterface here but that would be a little useless. So you should define an interface that exposes the public functionality you need the object to support and then have your class implement that interface.
This program demonstrates what I mean:
type
IUserData = interface
['{BA2B50F5-9151-4F84-94C8-6043464EC059}']
function GetData: Integer;
procedure SetData(Value: Integer);
property Data: Integer read GetData write SetData;
end;
TUserData = class(TInterfacedObject, IUserData)
private
FData: Integer;
function GetData: Integer;
procedure SetData(Value: Integer);
end;
function TUserData.GetData: Integer;
begin
Result := FData;
end;
procedure TUserData.SetData(Value: Integer);
begin
FData := Value;
end;
type
TTestRec = record
UserData: IUserData;
end;
procedure Main;
var
iRec: TTestRec;
begin
iRec.UserData := TUserData.Create;
end;
begin
Main;
ReportMemoryLeaksOnShutdown := True;
end.
This program does not leak. Change the variable declaration in the record type to UserData: TUserData and the leak returns.

Delphi XE8 unknown memory leaks in simple DataSnap client and server app

I have created a simple DataSnap client/server application with the wizard in Delphi XE8 using the echostring and reversestring sample methods. When I put "ReportMemoryLeaksOnShutdown := True" in the Server dpr and call the echostring and/or reversestring methods from the client the result is good but when I close the server application (after closing the client) I always get 2 or more unknown memory leaks. Is this a known bug which I can't find on the internet or is there a solution?
Server code:
unit ServerMethodsUnit;
interface
uses System.SysUtils, System.Classes, System.Json,
Datasnap.DSServer, Datasnap.DSAuth, DataSnap.DSProviderDataModuleAdapter;
type
{$METHODINFO ON}
TServerMethods = class(TDataModule)
private
{ Private declarations }
public
{ Public declarations }
function EchoString(Value: string): string;
function ReverseString(Value: string): string;
end;
{$METHODINFO OFF}
implementation
{%CLASSGROUP 'FMX.Controls.TControl'}
{$R *.dfm}
uses System.StrUtils;
function TServerMethods.EchoString(Value: string): string;
begin
Result := Value;
end;
function TServerMethods.ReverseString(Value: string): string;
begin
Result := System.StrUtils.ReverseString(Value);
end;
end.
dfm
object ServerContainer: TServerContainer
OldCreateOrder = False
Height = 271
Width = 415
object DSServer1: TDSServer
Left = 96
Top = 11
end
object DSTCPServerTransport1: TDSTCPServerTransport
Server = DSServer1
Filters = <>
Left = 96
Top = 73
end
object DSServerClass1: TDSServerClass
OnGetClass = DSServerClass1GetClass
Server = DSServer1
Left = 200
Top = 11
end
end
dfm project file
program DataSnap_Server;
uses
FMX.Forms,
Web.WebReq,
IdHTTPWebBrokerBridge,
ServerMainForm in 'ServerMainForm.pas' {Form2},
ServerMethodsUnit in 'ServerMethodsUnit.pas' {ServerMethods: TDataModule},
ServerContainerUnit in 'ServerContainerUnit.pas' {ServerContainer: TDataModule};
{$R *.res}
begin
ReportMemoryLeaksOnShutdown := True;
Application.Initialize;
Application.CreateForm(TForm2, Form2);
Application.CreateForm(TServerContainer, ServerContainer);
Application.Run;
end.
client side code generated source
//
// Created by the DataSnap proxy generator.
// 14-5-2015 22:45:56
//
unit ClientClassesUnit;
interface
uses System.JSON, Data.DBXCommon, Data.DBXClient, Data.DBXDataSnap, Data.DBXJSON, Datasnap.DSProxy, System.Classes, System.SysUtils, Data.DB, Data.SqlExpr, Data.DBXDBReaders, Data.DBXCDSReaders, Data.DBXJSONReflect;
type
TServerMethodsClient = class(TDSAdminClient)
private
FEchoStringCommand: TDBXCommand;
FReverseStringCommand: TDBXCommand;
public
constructor Create(ADBXConnection: TDBXConnection); overload;
constructor Create(ADBXConnection: TDBXConnection; AInstanceOwner: Boolean); overload;
destructor Destroy; override;
function EchoString(Value: string): string;
function ReverseString(Value: string): string;
end;
implementation
function TServerMethodsClient.EchoString(Value: string): string;
begin
if FEchoStringCommand = nil then
begin
FEchoStringCommand := FDBXConnection.CreateCommand;
FEchoStringCommand.CommandType := TDBXCommandTypes.DSServerMethod;
FEchoStringCommand.Text := 'TServerMethods.EchoString';
FEchoStringCommand.Prepare;
end;
FEchoStringCommand.Parameters[0].Value.SetWideString(Value);
FEchoStringCommand.ExecuteUpdate;
Result := FEchoStringCommand.Parameters[1].Value.GetWideString;
end;
function TServerMethodsClient.ReverseString(Value: string): string;
begin
if FReverseStringCommand = nil then
begin
FReverseStringCommand := FDBXConnection.CreateCommand;
FReverseStringCommand.CommandType := TDBXCommandTypes.DSServerMethod;
FReverseStringCommand.Text := 'TServerMethods.ReverseString';
FReverseStringCommand.Prepare;
end;
FReverseStringCommand.Parameters[0].Value.SetWideString(Value);
FReverseStringCommand.ExecuteUpdate;
Result := FReverseStringCommand.Parameters[1].Value.GetWideString;
end;
constructor TServerMethodsClient.Create(ADBXConnection: TDBXConnection);
begin
inherited Create(ADBXConnection);
end;
constructor TServerMethodsClient.Create(ADBXConnection: TDBXConnection; AInstanceOwner: Boolean);
begin
inherited Create(ADBXConnection, AInstanceOwner);
end;
destructor TServerMethodsClient.Destroy;
begin
FEchoStringCommand.DisposeOf;
FReverseStringCommand.DisposeOf;
inherited;
end;
end.
Own source
unit ClientMainForm;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
Button2: TButton;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses
ClientModuleUnit;
procedure TForm1.Button1Click(Sender: TObject);
begin
Label1.Caption := ClientModule.ServerMethodsClient.EchoString(Edit1.Text);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
Label1.Caption := ClientModule.ServerMethodsClient.ReverseString(Edit1.Text);
end;
end.
Memory leak looks like always exist, or, we doing something wrong.
What I checked:
I move all server app code into the one unit.
I try server app without FMX - with VCL.
I try to create TDSServer, TDSTCPServerTransport, TDSServerClass in runtime with parents Self and Nil.
I try with TServerMethod class owner TPersistance and TComponent (Delphi help says to use it).
I try with compiled server app as 32 bit and 64 bit application in Delphi XE7 Update 1 and in Delphi XE8.
EurekaLog 7.2.2 cannot catch details about memory leak also.
For avoid catching Access Violation by EurekaLog need to use DSServer1.Stop before exit.
As we could see Access Violation when you using EurekaLog happens there
Basically it's in
System.TObject.InheritsFrom(???)
System._IsClass($64AE4E0,TDSServerTransport)
Datasnap.DSCommonServer.TDSCustomServer.StopTransports
Datasnap.DSCommonServer.TDSCustomServer.Stop
Datasnap.DSServer.TDSServer.Stop
Datasnap.DSServer.TDSServer.Destroy
System.TObject.Free
System.Classes.TComponent.DestroyComponents
System.Classes.TComponent.Destroy
System.Classes.TDataModule.Destroy
System.TObject.Free
System.Classes.TComponent.DestroyComponents
FMX.Forms.DoneApplication
System.SysUtils.DoExitProc
System._Halt0
:00408da8 TObject.InheritsFrom + $8
Server app:
unit ufmMain;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
Datasnap.DSServer, Datasnap.DSTCPServerTransport, Datasnap.DSAuth, DataSnap.DSProviderDataModuleAdapter, Datasnap.DSCommonServer,
IPPeerServer;
type
{$METHODINFO ON}
TServerMethods = class(TComponent)
private
{ Private declarations }
public
{ Public declarations }
function EchoString(Value: string): string;
end;
{$METHODINFO OFF}
TfmMain = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
DSServer1: TDSServer;
DSTCPServerTransport1: TDSTCPServerTransport;
DSServerClass1: TDSServerClass;
procedure DSServerClass1GetClass(DSServerClass: TDSServerClass; var PersistentClass: TPersistentClass);
end;
var
fmMain: TfmMain;
implementation
{$R *.dfm}
uses System.StrUtils;
function TServerMethods.EchoString(Value: string): string;
begin
Result := Value;
end;
procedure TfmMain.DSServerClass1GetClass(DSServerClass: TDSServerClass; var PersistentClass: TPersistentClass);
begin
PersistentClass := TServerMethods;
end;
procedure TfmMain.FormCreate(Sender: TObject);
begin
DSServer1 := TDSServer.Create(nil);
DSServer1.Name := 'DSServer1';
DSServer1.AutoStart := False;
DSTCPServerTransport1 := TDSTCPServerTransport.Create(nil);
DSTCPServerTransport1.Server := DSServer1;
DSServerClass1 := TDSServerClass.Create(nil);
DSServerClass1.Server := DSServer1;
DSServerClass1.OnGetClass := DSServerClass1GetClass;
DSServer1.Start;
end;
procedure TfmMain.FormDestroy(Sender: TObject);
begin
DSServer1.Stop;
DSServerClass1.Free;
DSTCPServerTransport1.Free;
DSServer1.Free;
end;
end.
I guess it is a known bug for XE8 by now, I think it's pretty serious, at least serious enough for us NOT to use XE8 before Embarcadero has given us an answer on what's going on.
We had a similar issue in XE2, as far as I remember it was on heavy callbacks.
This Eurekalog doesn't tell me much, it looks like deep inside datasnap, sorry I don't know how to make the log more readable.
EDIT:
I reported this issue to Embarcadero and got this response today:
//
Hi Henrik,
Part of the memory leaks are due to a bug in the System.Collections.Generics.pas, we are looking at releasing a fix this issue in very near future.
brgds
Roy.
//
Thought you might wanna know :)

Again over interfaces in Delphi

In order to understand interfaces I've realized a small application with a form, a data module with a simple database.
here is the form
The data module contains only a connection, a table and a TDataSource component.
The interface unit is this:
unit databaseInterface;
interface
uses
MSAccess;
type
IDBTest = interface
['{5B8CF4FF-66F7-402D-8E18-0159CB22F805}']
procedure SetTable(table: TMSTable);
function SetPriorRecord: Boolean;
function SetNextRecord: Boolean;
end;
implementation
end.
and it's implementation is this:
unit databaseImplementation;
interface
uses
databaseInterface, database, MSAccess;
type
TDBTest = class(TInterfacedObject, IDBTest)
protected
DBTable: TMSTable;
FbtnPriorStatus: Boolean;
procedure SetTable(Table: TMSTable);
function SetPriorRecord: Boolean;
function SetNextRecord: Boolean;
public
property Table: TMSTable read DBTable write SetTable;
end;
implementation
{ TDBTest }
procedure TDBTest.SetTable(Table: TMSTable);
begin
if DBTable <> Table then begin
DBTable := Table;
DBTable.Open;
end;
end;
function TDBTest.SetPriorRecord: Boolean;
begin
if not DBTable.Bof then begin
DBTable.Prior;
Result := DBTable.Bof;
end else
Result := True;
end;
function TDBTest.SetNextRecord: Boolean;
begin
if not DBTable.Eof then begin
DBTable.Next;
Result := DBTable.Eof;
end else
Result := True;
end;
end.
Now, this is the question. The code of my form is as below:
unit main;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
Vcl.ExtCtrls, databaseInterface, databaseImplementation, JvExMask,
JvToolEdit, JvMaskEdit, JvCheckedMaskEdit, JvDatePickerEdit,
Vcl.StdCtrls, Vcl.Mask, Vcl.DBCtrls, JvDBDatePickerEdit, JvExControls,
JvButton, JvTransparentButton, database;
type
TfrmMain = class(TForm)
pnlCommands: TPanel;
pnlData: TPanel;
pnlMessages: TPanel;
bvlIcons: TBevel;
bvlNavigation: TBevel;
lblId: TLabel;
lblFirstName: TLabel;
lblLastName: TLabel;
lblBirthday: TLabel;
edtId: TDBEdit;
edtFirstName: TDBEdit;
edtLastName: TDBEdit;
dtpBirthday: TJvDBDatePickerEdit;
btnPrior: TJvTransparentButton;
btnNext: TJvTransparentButton;
procedure btnNextClick(Sender: TObject);
procedure btnPriorClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormActivate(Sender: TObject);
private
DBTest: IDBTest;
public
{ Public declarations }
end;
var
frmMain: TfrmMain;
implementation
{$R *.dfm}
procedure TfrmMain.FormCreate(Sender: TObject);
begin
DBTest := TDBTest.Create;
end;
procedure TfrmMain.FormActivate(Sender: TObject);
begin
DBTest.SetTable(dmAuthors.tblAuthors);
end;
procedure TfrmMain.btnPriorClick(Sender: TObject);
begin
btnPrior.Enabled := not DBTest.SetPriorRecord;
btnNext.Enabled := True;
end;
procedure TfrmMain.btnNextClick(Sender: TObject);
begin
btnNext.Enabled := not DBTest.SetNextRecord;
btnPrior.Enabled := True;
end;
end.
So I call the methods SetPriorRecord and SetNextRecord when the user click over the related button and then, accordingly with the status of the table (BOF or EOF), I disable or enable buttons.
I wonder if there is a way to set buttons status via interface, decoupling this operation from the form; for example binding buttons in any way or something else, but I don't know how to do it, if it is possible!
I hope I was clear in my explication of the problem.
The existing interface is not sufficient. You need to pass in some means of letting the client know the state of the table, but without exposing the TDataSet's detailed logic (preferably). A callback to an event handler would work; a way to trigger TAction would work; as would an anonymous method. You basically need to return a flag of some kind signifying BOF, EOF, or somewhere in between; possibly also a record# and record count.
I've modified the application interface in this way:
unit databaseInterface;
interface
uses
MSAccess;
type
IDBTest = interface
['{5B8CF4FF-66F7-402D-8E18-0159CB22F805}']
procedure SetTable(table: TMSTable);
procedure SetPriorRecord;
procedure SetNextRecord;
function GetIsBof: Boolean;
function GetIsEof: Boolean;
property IsBof: Boolean read GetIsBof;
property IsEof: Boolean read GetIsEof;
end;
implementation
end.
and this is the interface implementation:
unit databaseImplementation;
interface
uses
databaseInterface, database, MSAccess;
type
TDBTest = class(TInterfacedObject, IDBTest)
protected
DBTable: TMSTable;
FIsBof: Boolean;
FIsEof: Boolean;
procedure SetTable(Table: TMSTable);
procedure SetPriorRecord;
procedure SetNextRecord;
function GetIsBof: Boolean;
function GetIsEof: Boolean;
procedure SetCursorStatus;
public
property Table: TMSTable read DBTable write SetTable;
property IsBof: Boolean read GetIsBof;
property IsEof: Boolean read GetIsEof;
end;
implementation
{ TDBTest }
procedure TDBTest.SetTable(Table: TMSTable);
begin
if DBTable <> Table then begin
DBTable := Table;
DBTable.Open;
end;
end;
procedure TDBTest.SetPriorRecord;
begin
try
DBTable.Prior;
finally
SetCursorStatus;
end;
end;
procedure TDBTest.SetNextRecord;
begin
try
DBTable.Next;
finally
SetCursorStatus;
end;
end;
procedure TDBTest.SetCursorStatus;
begin
FIsBof := DBTable.Bof;
FIsEof := DBTable.Eof;
end;
function TDBTest.GetIsBof: Boolean;
begin
Result := FIsBof;
end;
function TDBTest.GetIsEof: Boolean;
begin
Result := FIsEof;
end;
end.
So the form code become this:
unit main;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
Vcl.ExtCtrls, Vcl.StdCtrls, Vcl.Mask, Vcl.DBCtrls, JvExMask, JvToolEdit,
JvMaskEdit, JvCheckedMaskEdit, JvDatePickerEdit, JvDBDatePickerEdit,
JvExControls, JvButton, JvTransparentButton, database, databaseInterface,
databaseImplementation;
type
TfrmMain = class(TForm)
pnlCommands: TPanel;
pnlData: TPanel;
pnlMessages: TPanel;
bvlIcons: TBevel;
bvlNavigation: TBevel;
lblId: TLabel;
lblFirstName: TLabel;
lblLastName: TLabel;
lblBirthday: TLabel;
edtId: TDBEdit;
edtFirstName: TDBEdit;
edtLastName: TDBEdit;
dtpBirthday: TJvDBDatePickerEdit;
btnPrior: TJvTransparentButton;
btnNext: TJvTransparentButton;
procedure btnNextClick(Sender: TObject);
procedure btnPriorClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormActivate(Sender: TObject);
private
DBTest: IDBTest;
procedure SetNavButtonsStatus;
public
{ Public declarations }
end;
var
frmMain: TfrmMain;
implementation
{$R *.dfm}
procedure TfrmMain.FormCreate(Sender: TObject);
begin
DBTest := TDBTest.Create;
end;
procedure TfrmMain.FormActivate(Sender: TObject);
begin
DBTest.SetTable(dmAuthors.tblAuthors);
end;
{ Begin table navigation ----------------------------------------------------- }
procedure TfrmMain.btnPriorClick(Sender: TObject);
begin
DBTest.SetPriorRecord;
SetNavButtonsStatus;
end;
procedure TfrmMain.btnNextClick(Sender: TObject);
begin
DBTest.SetNextRecord;
SetNavButtonsStatus;
end;
procedure TfrmMain.SetNavButtonsStatus;
begin
btnPrior.Enabled := not DBTest.IsBof;
btnNext.Enabled := not DBTest.IsEof
end;
{ End table navigation ------------------------------------------------------- }
end.
Now I think buttons are decoupled, but I'm not sure abot the solution I've found. Can It be good?

Interface DLL form app crashing

I have problem with host application, which loads DLL form and interfaceing some function and properties.
The purpose is load a dll, show name as module name, set connection to ADOTable component and show form with data. Everything is working fine. But after close the host app a host app crashed and I get windows that hostapp.exe stopped working.
I do not know whether it is by freeing library or setting nil for interface.
Do you have any solution? Thanks.
Interface CODE
unit u_baseplugin_intf;
interface
uses Data.Win.ADODB, Data.DB;
type
IBaseModuleInterface = interface
['{060A9C46-B3CF-4BA4-B025-2DC1D9F45076}']
function GetModuleName: Ansistring;stdcall;
procedure SetConn(sConn:TAdoConnection);stdcall;
procedure showF;stdcall;
procedure freeF;stdcall;
property ModuleName: Ansistring read GetModuleName;
property Connection : TAdoConnection write SetConn;
end;
implementation
end.
DLL code
library profileslist;
uses
System.SysUtils,
System.Classes,
u_baseplugin_intf,
u_profileslist in 'u_profileslist.pas' {Form_DLL};
{$R *.res}
function LoadModule:IBaseModuleInterface;stdcall;
begin
result:=TForm_DLL.Create(nil);
end;
exports
LoadModule;
begin
end.
DLL Form code
unit u_profileslist;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.Grids, Vcl.DBGrids, Vcl.StdCtrls,
u_baseplugin_intf, Data.DB,Data.Win.ADODB;
type
TForm_DLL = class(TForm, IBaseModuleInterface)
DBGrid1: TDBGrid;
ADOTable1: TADOTable;
DataSource1: TDataSource;
procedure FormShow(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
{Interface methods implementation}
function GetModuleName: AnsiString;stdcall;
procedure SetConn(sConn:TAdoConnection);stdcall;
public
{ Public declarations }
{Interface methods implementation}
procedure ShowF;stdcall;
procedure FreeF;stdcall;
end;
var
Form_DLL: TForm_DLL;
implementation
{$R *.dfm}
{Interface methods implementation}
function TForm_DLL.GetModuleName;
begin
Result := 'Profiles list';
end;
procedure TForm_DLL.SetConn(sConn: TAdoConnection);
begin
AdoTable1.Connection:=sConn;
end;
procedure TForm_DLL.ShowF;
begin
ShowModal;
end;
procedure TForm_DLL.FreeF;
begin
FreeAndNil(Form_DLL);
end;
{Form_DLL methods implementation}
procedure TForm_DLL.FormClose(Sender: TObject; var Action: TCloseAction);
begin
AdoTable1.Active:=false;
end;
procedure TForm_DLL.FormShow(Sender: TObject);
begin
AdoTable1.Active:=true;
end;
end.
HOST app code
program hostapp;
uses
Vcl.Forms,
u_hostapp in 'u_hostapp.pas' {Form1},
u_baseplugin_intf in 'u_baseplugin_intf.pas';
{$R *.res}
begin
Application.Initialize;
Application.MainFormOnTaskbar := True;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
Host app FORM code
unit u_hostapp;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls,
u_baseplugin_intf,
Data.Win.ADODB, Data.DB;
type
TForm1 = class(TForm)
ADOConnection1: TADOConnection;
Button1: TButton;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
type
TModuleInterface = function:IBaseModuleInterface; stdcall;
var
Form1: TForm1;
implementation
{$R *.dfm}
var
aModuleIntf : IBaseModuleInterface;
dllHandle : cardinal;
procedure LoadModule( aLibName : pWideChar );
var
lModule : TModuleInterface;
begin
dllHandle := LoadLibrary(aLibName) ;
if dllHandle <> 0 then
begin
#lModule := GetProcAddress(dllHandle, 'LoadModule') ;
if Assigned (lModule) then
aModuleIntf := lModule //call the function
else
begin
ShowMessage('GetModuleIntf not found.') ;
FreeLibrary(dllHandle) ;
end;
end
else
begin
ShowMessage(aLibName+' not found.') ;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
aModuleIntf.Connection:=AdoConnection1;
aModuleIntf.ShowF;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
aModuleIntf.Connection:=nil;
aModuleIntf.freeF;
aModuleIntf:=nil;
FreeLibrary(dllHandle);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
LoadModule('profileslist.dll');
Label1.Caption:=aModuleIntf.ModuleName;
end;
end.
You never assign to Form_DLL. This means that when you call FreeF, you then perform FreeAndNil(Form_DLL). Since Form_DLL is nil, this does nothing, and the form still exists.
Fix that by changing LoadModule:
function LoadModule:IBaseModuleInterface;stdcall;
begin
Assert(not Assigned(Form_DLL));
Form_DLL:=TForm_DLL.Create(nil);
result:=Form_DLL;
end;
Although, I'd probably change the design completely by removing Form_DLL altogether. The host app maintains a reference to the form, on which the call to Free can be made. In other words, remove Form_DLL and implement FreeF like this:
procedure TForm_DLL.FreeF;
begin
Free; // or Destroy
end;
Or even better, use reference counted interfaces on the implementing object and let aModuleIntf:=nil take the form down.

Resources