Delphi & shared datasources - delphi

In my app I have different forms that use the same datasource (so the queries are the same too), defined in a common datamodule. Question is, is there a way to know how many times did I open a specific query? By being able to do this, I could avoid close that query without closing it "every where else".
Edit: It's important to mention that I'm using Delphi3 and it is not a single query but several.

The idea is to use the DataLinks property of the TDataSource.
But, as it is protected, you have to gain access to it. One common trick is to create a fake descendant just for the purpose of casting:
type
TDataSourceHack = class(TDataSource);
Then you use it like:
IsUsed := TDataSourceHack(DataSource1).DataLinks.Count > 0;

You can get creative using a addref/release like approach. Just create a few functions and an integer variable in your shared datamodule to do the magic, and be sure to call them..partial code follows:
TDMShared = class(tDataModule)
private
fQueryCount : integer; // set to 0 in constructor
public
function GetQuery : tDataset;
procedure CloseQuery;
end;
function TDMShared.GetQuery : tDataset;
begin
inc(fQueryCount);
if fQueryCount = 1 then
SharedDatsetQry.open;
Result := shareddatasetqry; // your shared dataset here
end;
procedure TDMShared.CloseQuery;
begin
dec(fQueryCount);
if fQueryCount <= 0 then
shareddatasetqry.close; // close only when no refs left.
end;
EDIT: To do this with multiple queries, you need a container to hold the query references, and a way to manipulate them. a tList works well for this. You will need to make appropriate changes for your TDataset descendant, as well as create a FreeAndNil function if you are using an older version of Delphi. The concept I used for this was to maintain a list of all queries you request and manipulate them by the handle which is in effect the index of the query in the list. The method FreeUnusedQueries is there to free any objects which no longer have a reference...this can also be done as part of the close query method, but I separated it to handle the cases where a specific query would need to be reopened by another module.
Procedure TDMShared.DataModuleCreate(Sender:tObject);
begin
dsList := tList.create;
end;
Function TDMShared.CreateQuery(aSql:String):integer;
var
ds : tAdoDataset;
begin
// create your dataset here, for this example using TADODataset
ds := tAdoDataset.create(nil); // self managed
ds.connection := database;
ds.commandtext := aSql;
ds.tag := 0;
Result := dsList.add(ds);
end;
function TDMShared.GetQuery( handle : integer ) : tDataset;
begin
result := nil;
if handle > dsList.count-1 then exit;
if dsList.Items[ handle ] = nil then exit; // handle already closed
result := tAdoDataset( dsList.items[ handle ]);
Inc(Result.tag);
if Result.Tag = 1 then
Result.Open;
end;
procedure TDMShared.CloseQuery( handle : integer );
var
ds : tAdoDataset;
begin
if handle > dsLIst.count-1 then exit;
ds := tAdoDataset( dsList.items[ handle ]);
dec(ds.Tag);
if ds.Tag <= 0 then
ds.close;
end;
procedure TDMShared.FreeUnusedQueries;
var
ds : tAdoDataset;
ix : integer;
begin
for ix := 0 to dsList.Count - 1 do
begin
ds := tAdoDataset(dsLIst.Items[ ix ]);
if ds.tag <= 0 then
FreeAndNil(dsList.Items[ix]);
end;
end;
procedure TDMShared.DataModuleDestroy(Sender: TObject);
var
ix : integer;
begin
for ix := 0 to dsList.count-1 do
begin
if dsLIst.Items[ix] <> nil then
FreeAndNil(dsLIst.Items[ix]);
end;
dsList.free;
end;

Ok, a completely different solution...one that should work for Delphi 3.
Create a new "Descendant Object" from your existing dataset into a new unit, and add some behavior in the new object. Unfortunately I do not have Delphi 3 available for testing, but it should work if you can find the proper access points. For example:
TMySharedDataset = class(tOriginalDataset)
private
fOpenCount : integer;
protected
procedure Internal_Open; override;
procedure Internal_Close; override;
end;
TMySharedDataset.Internal_Open;
begin
inherited Internal_Open;
inc(fOpenCount);
end;
TMySharedDataset.Internal_Close;
begin
dec(fOpenCount);
if fOpenCount <= 0 then
Inherited Internal_Close;
end;
Then just include the unit in your data module, and change the reference to your shared dataset (you will also have to register this one and add it to the palette if your using components). Once this is done, you won't have to make changes to the other units as the dataset is still a descendant of your original one. What makes this all work is the creation of YOUR overridden object.

You could have a generic TDataSet on the shared datamodule and set it on the OnDataChange, using the DataSet property of the Field parameter
dstDataSet := Field.DataSet;
This way, when you want to close the dataset, close the dataset on the datamodule, which is a pointer to the correct DataSet on some form you don't even have to know

Related

Procedure to find component in new unit

I try to create new unit Ado_Op , in this unit i try to create a procedure like this :
procedure CloseAllTables ();
Var I : Integer; T : TADOTable;
begin
for I := 1 to ComponentCount-1 do
if Components[i] is TADOTable then
begin
T := FindComponent(Components[i].Name) as TADOTable;
T.Close;
end;
T.Destroy;
end;
Error :
ComponentCount inaccessible.
Note : I'm using Delphi 10 Seattle.
The compiler error you report is just the beginning of your problems. There are quite a few more. I see the following problems, with item 1 being the one noted in the question:
You need to supply an object on which to refer to the properties ComponentCount and Components[].
You are erroneously using one based indexing.
You needlessly call FindComponent to find the component that you already have.
You call Destroy once only, on whichever object you found last. Or on an uninitialized variable if you don't find any. The compiler should warn of this, and I do hope you have warnings and hints enabled, and heed them.
Based on the comments you are trying to call the Close method on each table owned by a form. Do that like so:
procedure CloseAllTables(Owner: TComponent);
var
i: Integer;
begin
for i := 0 to Owner.ComponentCount-1 do
if Owner.Components[i] is TADOTable then
TADOTable(Owner.Components[i]).Close;
end;
If you wish to destroy all of these components too, which I doubt, then you would need to run the loop in descending order. That's because when you destroy an component, it is removed from its owners list of components. That code would look like this, assuming that there was no need to call Close on an object that is about to be destroyed.
procedure DestroyAllTables(Owner: TComponent);
var
i: Integer;
begin
for i := Owner.ComponentCount-1 downto 0 do
if Owner.Components[i] is TADOTable then
Owner.Components[i].Free;
end;

Implementing TObjectList's sort without copy/paste code

I have a procedure for sorting nodes in a node tree (VirtualTreeView)
All memory leaks, extracted from FMM4 report, are stored in objects of a class TMemoryLeakList(these are the list I want to sort), which are stored in a list of lists called TGroupedMemoryLeakList, and both TMLL and TGMLL extend TObjectList. If I want to keep the functionality of being able to chose between ascending and descending sort order and choosing between sorting by one of four different data types, I 'have to' implement EIGHT different comparison methods (4 sort types * 2 sort directions) which I pass on to the main sorting method, because my TMLL list extends TObjectList. The main sorting method look like this.
The values for the fields fSortType and fSortDirection are acquired from the GUI comboboxes.
One of those eight generic comparison functions looks like this.
The seven remaining are copy/pasted variations of this one.
Is there any rational way to refactor this huge amount of copy paste code and still keep the functionality of choosing a specific sort type and direction?
Nice question about refactoring, but I dislike the answer you presumably are looking for. There is nothing wrong with a few extra lines of code, or a few extra routines. Especially the latter in which case naming actively assist in more readability.
My advice would be: leave the design as you have, but shorten the code:
function CompareSizeAsc(Item1, Item2: Pointer): Integer;
begin
Result := TMemoryLeak(Item2).Size - TMemoryLeak(Item1).Size;
end;
function CompareSizeDesc(Item1, Item2: Pointer): Integer;
begin
Result := TMemoryLeak(Item1).Size - TMemoryLeak(Item2).Size;
end;
function CompareClassNameAsc(Item1, Item2: Pointer): Integer;
begin
Result := CompareStr(TMemoryLeak(Item1).ClassName,
TMemoryLeak(Item2).ClassName);
end;
procedure TMemoryLeakList.Sort;
begin
case FSortDirection of
sdAsc:
case FSortType of
stSize: inherited Sort(CompareSizeAsc);
stClassName: inherited Sort(CompareClassNameAsc);
stCallStackSize: inherited Sort(CompareCallStackSizeAsc);
stId: inherited Sort(CompareIdAsc);
end;
sdDesc:
case FSortType of
stSize: inherited Sort(CompareSizeDesc);
stClassName: inherited Sort(CompareClassNameDesc);
stCallStackSize: inherited Sort(CompareCallStackSizeDesc);
stId: inherited Sort(CompareIdDesc);
end;
end;
end;
You can't get it much smaller then this ánd preserve the same level of readability.
Of course, you could rewrite the Sort routine as suggested by Arioch 'The:
procedure TMemoryLeakList.Sort;
const
Compares: array[TSortDirection, TSortType] of TListSortCompare =
((CompareSizeAsc, CompareClassNameAsc, CompareCallStackSizeAsc,
CompareIdAsc), (CompareSizeDesc, CompareClassNameDesc,
CompareCallStackSizeDesc, CompareIdDesc));
begin
inherited Sort(Compares[FSortDirection, FSortType]);
end;
But then: why not rewrite the QuickSort routine to eliminate the need for separate compare routines?
Alternatively, you could add ownership to TMemoryLeak in which case you have a reference to the owning list and its sort direction and sort type, for use within óne single compare routine.
Use function pointers.
var comparator1, comparator2: function (Item1, Item2: Pointer): Integer;
function sortComplex (Item1, Item2: Pointer): Integer;
begin
Result := comparator1(Item1, Item2);
if 0 = Result then Result := comparator2(Item1, Item2);
end;
Then you GUI elements should behave like
case ListSortType.ItemIndex of
itemBySzie : comparator1 := sortBySizeProcAsc;
....
end;
DoNewSort;
PS: make sure that you correctly specify those pointers even before user 1st click any GUI element;
PPS: you can rearrange this even further like
type t_criteria = (bySize, byName,...);
t_comparators = array[t_criteria] of array [boolean {Descending?}]
of function (Item1, Item2: Pointer): Integer;
const comparator1table: t_comparators =
( {bySize} ( {false} sortBySizeProcAsc, {true} sortBySizeProcDesc),
{byName} ( {false} sortByNameProcAsc, ...
Then you would fill working pointers from that array constants
This is my solution. Apart from completely rewriting the two procedures I also added two 'static' variables to my TMemoryLeakList class, and removed the former instance variables of the same name. This way, they are globally accessible to the Sort function.
TMemoryLeakList=class(TObjectList)
class var fSortType :TMlSortType;
class var fSortDirection :TMLSortDirection;
...
end
procedure TMemoryLeakList.Sort;
begin
inherited sort(sortBySomethingSomething);
end;
function sortBySomethingSomething(Item1, Item2: Pointer): Integer;
var
a, b : string;
ret : Integer;
begin
ret := 1;
if(TMemoryLeakList.fSortDirection = sdAsc) then
ret := -1;
case TMemoryLeakList.fSortType of stSize:
begin
a := IntToStr(TMemoryLeak(Item1).Size);
b := IntToStr(TmemoryLeak(Item2).Size);
end;
end;
case TMemoryLeakList.fSortType of stClassName:
begin
a := TMemoryLeak(Item1).ClassName;
b := TMemoryLeak(Item2).ClassName;
end;
end;
case TMemoryLeakList.fSortType of stID:
begin
a := IntToStr(TMemoryLeak(Item1).ID);
b := IntToStr(TMemoryLeak(Item2).ID);
end;
end;
case TMemoryLeakList.fSortType of stCallStackSize:
begin
a := IntToStr(TMemoryLeak(Item1).CallStack.Count);
b := IntToStr(TMemoryLeak(Item2).CallStack.Count);
end;
end;
//...jos tu
if a=b then
Result:=0
else if a>b then
Result:=-1*ret
else if a<b then
Result:=1*ret;
end;
I would like to rewrite this solution so as to use instance bounded variables fSortType,fSortDirection in TMemoryLeakList, but it seems impossible to pass a member function to an inherited sort function (from TObjectList), or is it?

Why does setting a table's RecNo property not move to that record?

I have got a TTable component that uses the BDE to access a DBase table. There is no index on the table, so the sort order is the physical order of the records in the table. If I read the RecNo property, it contains the expected number for the current record.
I was under the impression that with this constellation (BDE + DBase) it is also possible to set the RecNo property to move to the corresponding record. But apparently this does not work in my program.
So: Do I remember this incorrectly? Or is there anything special I need to do for this to work?
(Please do not advise about dropping the BDE. I am aware of its issues and we are already migrating away from it.)
TBDEDataSet implements RecNo setter only for Paradox (not DBase).
unit DBTables;
...
procedure TBDEDataSet.SetRecNo(Value: Integer);
begin
CheckBrowseMode;
if (FRecNoStatus = rnParadox) and (Value <> RecNo) then
begin
DoBeforeScroll;
if DbiSetToSeqNo(Handle, Value) = DBIERR_NONE then
begin
Resync([rmCenter]);
DoAfterScroll;
end;
end;
end;
You might want to try something generic like this:
procedure SetRecNo(DataSet: TDataSet; const RecNo: Integer);
var
ActiveRecNo, Distance: Integer;
begin
if (RecNo > 0) then
begin
ActiveRecNo := DataSet.RecNo;
if (RecNo <> ActiveRecNo) then
begin
DataSet.DisableControls;
try
Distance := RecNo - ActiveRecNo;
DataSet.MoveBy(Distance);
finally
DataSet.EnableControls;
end;
end;
end;
end;

Delphi : Globally change ADO command timeout

We have a HUGE Delphi 2005 application with LOTS of ADO components (TADODataset, TADOStoredPRoc, TADOCommand...) spread on hundreads of forms. All of them are connected to a SINGLE TADOConnection.
Most of these components have their CommandTimeout property set to the default (30s) but a few have it set to 5 minutes (300s) and some are set to never timeout (0s).
I'd like to be able to globally change this setting for all ADO components application-wide. I'd prefer to do it programmatically at runtime so that I could tweak the timeouts on a per-installation basis if I need to.
I was hoping I could find a global event on the connection when an ADO component is created/attached, where I could tweak the commandtimeout, or hack my way into injecting my code in the components themselves, but came up blank.
I don't want to create decendants because I'll have to search/replace trought all the components, and if I ever forget to use the descendants instead of the regular ADO components my timeout wont follow the rest of the application.
Anybody has an idea how we could do this ?
If all of you ADO components are placed on a form, you can iterate over all forms using the Screen.Forms and Screen.FormCount properties. For each form iterate over its ComponentCount/Components property and check for TADOCommand, TADODataSet, TADOQuery, TADOStoredProc and TADOTable. Then you can set the timeout as you wish. Of course, if you create forms dynamically you have to take this into account separately.
The following code may guide you.
procedure SetADOTimeout(ATimeout: Integer);
var
cmp: TComponent;
frm: TForm;
I: Integer;
J: Integer;
begin
for I := 0 to Screen.FormCount - 1 do begin
frm := Screen.Forms[I];
for J := 0 to frm.ComponentCount - 1 do begin
cmp := frm.Components[J];
if cmp is TADOCommand then
TADOCommand(cmp).CommandTimeout := ATimeout
else if cmp is TADODataSet then
TADODataSet(cmp).CommandTimeout := ATimeout
else if cmp is TADOQuery then
TADOQuery(cmp).CommandTimeout := ATimeout
else if cmp is TADOStoredProc then
TADOStoredProc(cmp).CommandTimeout := ATimeout
else if cmp is TADOTable then
TADOTable(cmp).CommandTimeout := ATimeout;
end;
end;
end;
Greetings to all Argentinian solutions!
Just define the OnWillExecute event handler for the TADOConnection you have and write following code:
type
TCustomADODataSetAccess = class(TCustomADODataSet);
procedure TYourDataModule.ADOConnectionWillExecute(...);
var
i: Integer;
begin
for i := 0 to ADOConnection.DataSetCount - 1 do
TCustomADODataSetAccess(ADOConnection.DataSets[i]).CommandTimeout := Connection.CommandTimeout;
end;
This will set the command timeout for any query/table/stored procedure which uses your ADO connection.
According to the documentation, you can use CommandCount and Commands to locate all the open components attached to your TADOConnection.
Your problem is likely to be dynamically created forms. You'll need to find "something" to hook when a form is created and check for ADO components on that form.
If your forms descend from a custom form class, you could do this in the form's constructor or OnCreate event.
If not, you could look at TApplicationEvents and using the TApplication's OnIdle event.
Since CommandTimeout is introduced in the TCustomADODataset class, you can iterate for each form/datamodule, find a TCustomADODataset and it's descendants (ADODataset, ADOTable, ADOQuery) then set the Property.
procedure SetADOCommandTimeOut(aTimeOut: integer);
var
i, j: integer;
begin
for i:= 0 to Screen.FormCount-1 do
begin
for j:= 0 to Forms[i].ComponentCount-1 do
if Forms[i].Components[j] is TCustomADODataset then
TCustomADODataset1(Forms[i].Components[j]).CommandTimeOut:= aTimeOut;
end;
for i:= 0 to Screen.DataModuleCount-1 do
begin
for j:= 0 to Datamodules[i].ComponentCount-1 do
if Datamodules[i].Components[j] is TCustomADODataset then
TCustomADODataset1(Datamodules[i].Components[j]).CommandTimeOut:= aTimeOut;
end;
end;
Note: TCustomADODataset1 is exactly TCustomADODataset, only it has a published CommandTimeOut property :
TCustomADODataset1 = class(TCustomADODataset)
published
property CommandTimeOut;
end;
But it's only applied to forms/datamodules which are already created. If you create your forms/datamodules dynamically, then you must apply it whenever a new form/datamodule is created.
One way to do it is by override Notification in your Mainform, checking for a new a creation of form/datamodule, but this a little bit tricky since at the the creation time, all the components are not created yet. You trick it by delay it for a while using a timer (I don't know a more elegant way - just to show the idea)
Procedure TMainForm.Notification(AComponent: TComponent; Operation: TOperation);
begin
inherited;
if (Operation = opInsert) and (
((AComponent is TForm) and not (aComponent is TMainForm)) // exclude MainForm
or (AComponent is TDataModule)
) then
begin
Timer1.Interval:= 2000; // 2 seconds ?
Timer1.Enabled:= True;
end;
end;
Procedure TMainForm.Timer1Timer(Sender: TObject);
begin
Timer1.Enabled:= False;
SetADOCommandTimeOut(MyTimeOut);
end;
You create datamodule hierarchies? If so, you can use code like Uwe's answer on your patriarch form (which all other datamodules inherit).

Freeing Multiply-referenced Objects

This is another post about me inheriting an Intraweb app that had a 2MB text file of memory leaks as reported by FastMM4, where I've got it down to 115 instances of one class leaking 52 bytes each.
The leaks are from a rather convoluted instantiation and handling of the class. Each instantiation of the class is needed to get the app to work right now. So I'm looking for some ways to either clone the class with some straight-forward cleanup of the clone, or referencing in a different way, or..?
The first instantiation of the class (TCwcBasicAdapter) is as a local variable that gets added to a TObjectList (not Owning) and destroyed with the TObjectList (FCDSAdapters):
procedure TCwcDeclaration.AttachAdapter(DS: TDataSource; const FormName, KeyFN, TitleFN: string; const Multiple: boolean = False;
const AllowAttachment: boolean = False; const AllowComment: boolean = False);
var
Forms : TCwcSessionForms;
Adapter: TCwcCDSAdapter;
KeyField, TitleField: TField;
begin
Forms := GetForms(FormName);
KeyField := DS.DataSet.FindField(KeyFN);
TitleField := DS.DataSet.FindField(TitleFN);
Adapter := TCwcBasicAdapter.Create(DS, KeyField, TitleField, Multiple);
Adapter.AttachDBPersist(Self.DBPersist);
Forms.AttachDataAdapter(Adapter);
Forms.SetAllowAttachments(AllowAttachment);
Forms.SetAllowComments(AllowComment);
end;
procedure TCwcSessionForms.AttachDataAdapter(aCDSAdapter: TCwcCDSAdapter);
var
Index: integer;
begin
if (FCDSAdapters.IndexOf(aCDSAdapter) -1)
then raise Exception.CreateFmt('Duplicate Adapter attempting to be attached on %0:s', [FFormClassName]);
Index := FCDSAdapters.Add(aCDSAdapter);
if (FDefaultAdapterIndex = -1)
then FDefaultAdapterIndex := Index;
end;
The second instantiation of the class is also as a local variable that gets added to a TObjectList (not Owning) and destroyed with the TObjectList (FAdapters):
procedure TCwcCDSMulticastList.InitializeAdapters(const aSessionForms: TCwcSessionForms);
var
i, Count: integer;
Adapter: TCwcCDSAdapter;
TempMulticast: TCwcCDSEventMulticast;
begin
Count := aSessionForms.GetDataAdapterCount;
for i := 0 to Pred(Count) do begin
Adapter := aSessionForms.GetDataAdapter(i);
TempMulticast := FindDataSource(Adapter.DataSource);
if (TempMulticast = nil) then begin
TempMulticast := TCwcCDSEventMulticast.Create(Adapter.DataSource);
try
FMulticastList.Add(TempMulticast);
except
FreeAndNil(TempMulticast);
raise;
end;
end;
TempMulticast.AddObserver(Adapter);
FAdapters.Add(Adapter);
end;
end;
The third instantiation of the class is as part of an observer pattern from the TempMulticast.AddObserver(Adapter) line above. The observer is added to TObjectList FObservers (Owning):
procedure TCwcCDSEventMulticast.AddObserver(const aCDSAdapter: TCwcCDSAdapter);
begin
FObservers.Add(TCwcCDSAdapterObserver.Create(aCDSAdapter));
end;
constructor TCwcCDSAdapterObserver.Create(const aCDSAdapter: TCwcCDSAdapter);
begin
inherited Create;
FOnStateChange := aCDSAdapter.OnStateChangeIntercept;
FOnAfterDelete := aCDSAdapter.AfterDeleteIntercept;
FInvalidateCursors := aCDSAdapter.InvalidateCursors;
end;
The TCwcBasicAdapter is leaked here, not cleaned up when FObservers is destroyed.
The latest thing I've tried is changing FObservers to not Owning, creating a private field for the Adapter, freeing the private field in TCwcCDSAdapterObserver.Destroy, but that causes errors.
Thanks,
Paul Rice
If the lists aren't owners, then they will not free the objects when the list is freed. Just calling Remove on each item won't do it either. You would have to iterate through the list and call Free on each item in the list, and then free the list itself.
If you make the lists owners, then they will do this for you when you free the list.
for i := 0 to FAdapters.Count do Free(FAdapters[i]);
FreeAndNil(FAdapters);
You realize you can dispose of objects by yourself without making their owners auto-dispose of them? I ask this because it feels like you're trying to make the automatics do the job in all cases.

Resources