Delphi Thread doesn't run [duplicate] - delphi

This question already has an answer here:
Delphi Access Violation when moving button on form
(1 answer)
Closed 7 years ago.
I'm trying to search for all files in all subfolders so it takes long time and application stop responding, so I used Thread (it's first time work with Threads) I read about it and I found this way to create and execute threads, but nothing happen when I call the thread, and I don't understand why I couldn't use the added components on the main form, I had to re-declare it again?
what I miss here?
type
TSearchThread = class(TThread)
private
{ Private declarations }
protected
procedure Execute; override;
end;
procedure AddAllFilesInDir(const Path: string; ListBox:TsListBox);
var
SR: TSearchRec;
I: Integer;
begin
if FindFirst(IncludeTrailingBackslash(Path) + '*.*', faAnyFile or faDirectory, SR) = 0 then
try
repeat
if (SR.Attr and faDirectory) = 0 then
ListBox.Items.Add(Path+'\'+SR.Name)
else if (SR.Name <> '.') and (SR.Name <> '..') then
AddAllFilesInDir(IncludeTrailingBackslash(Path) + SR.Name, ListBox);
Form1.sPanel2.Caption := Path+'\'+SR.Name;
Form1.sPanel2.Refresh;
ListBox.Refresh;
until FindNext(Sr) <> 0;
finally
FindClose(SR);
end;
end;
procedure TSearchThread.Execute;
var FileList: TsListBox;
I: Integer;
{Here I had to re-declare objects}
sDirectoryEdit1: TsDirectoryEdit;
sListBox1: TsListBox;
begin
FileList := TsListBox.Create(nil);
FileList.Parent := sListBox1;
FileList.Visible := False;
AddAllFilesInDir(sDirectoryEdit1.Text+'\', FileList);
for I := 0 to FileList.Count -1 do
if sListBox1.Items.IndexOf(FileList.Items.Strings[I]) = -1 then
sListBox1.Items.Add(FileList.Items.Strings[I]);
FileList.Clear;
end;
procedure TForm1.sDirectoryEdit1Change(Sender: TObject);
begin
TSearchThread.Create(False);
end;

Ok, let me give it a try:
First a new version of your thread:
uses
IOUtils;
type
TFileFoundEvent = procedure(const Path: string; const SearchRec: TSearchRec) of object;
TSearchThread = class(TThread)
private
FPath: string;
FSearchRec: TSearchRec;
FFileFoundEvent: TFileFoundEvent;
protected
procedure Execute; override;
public
Constructor Create(const aPath: string; aFileFoundEvent: TFileFoundEvent); reintroduce;
end;
{ TSearchThread }
constructor TSearchThread.Create(const aPath: string; aFileFoundEvent: TFileFoundEvent);
begin
// Create the Thread non suspended
inherited Create(false);
// Copy parameters to local members.
FFileFoundEvent := aFileFoundEvent;
FPath := aPath;
// Make the sure the thread frees itself after execution
FreeOnTerminate := True;
end;
procedure TSearchThread.Execute;
var
FilterPredicate: TDirectory.TFilterPredicate;
begin
// FilterPredicate is an in-place anonymous method to be called each time the TDirectory.GetFiles finds a file
FilterPredicate := function(const Path: string; const SearchRec: TSearchRec): Boolean
begin
// Since we can not access from within Synchronize we need to copy iot to a member of the class
FSearchRec := SearchRec;
// You cannot access VCL objects directly from a thread.
// So you need to call Syncronize
// For more info look in the online help
// http://docwiki.embarcadero.com/Libraries/Seattle/en/System.Classes.TThread.Synchronize
Synchronize(nil,
procedure
begin
FFileFoundEvent(FPath, FSearchRec);
end);
Result := True;
end;
// Do the search
TDirectory.GetFiles(FPath, TSearchOption.soTopDirectoryOnly, FilterPredicate)
end;
The main diffrence are that I pass a callback proceudre onto the constructor of the thread. And ofcause I uses TDirectory.GetFiles to search for files. You'll find TDirectory.GetFiles in IOUtils
Then you need to use it: Place a Listbox on your from and then call it like this :
Form definition:
type
TForm1 = class(TForm)
ListBox1: TListBox;
procedure FormCreate(Sender: TObject);
private
procedure FileFoundEvent(const Path: string; const SearchRec: TSearchRec);
public
{ Public declarations }
end;
...
implementation
procedure TForm1.FileFoundEvent(const Path: string; const SearchRec: TSearchRec);
begin
ListBox1.Items.Add(SearchRec.Name);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
TSearchThread.Create(ExtractFilePath(Application.ExeName), FileFoundEvent);
end;
If you don't want to see the ongoing results of the searching, but rather want some speed you can create a version of the searchthread that gives you the result all at once:
uses
IOUtils;
type
TSearchThread = class(TThread)
private
FSearchPath: String;
FResultBuffer: TStrings;
protected
procedure Execute; override;
public
constructor Create(const aSearchPath: string; aResultBuffer: TStrings); overload;
end;
constructor TSearchThread.Create(const aSearchPath: string; aResultBuffer: TStrings);
begin
inherited Create(false);
FSearchPath := IncludeTrailingPathDelimiter(aSearchPath);
FResultBuffer := aResultBuffer;
FreeOnTerminate := True;
end;
procedure TSearchThread.Execute;
var
FBuffer: TStringlist;
Filename: String;
begin
Synchronize(nil,
procedure
begin
FResultBuffer.Text := 'Searching ' + FSearchPath;
end);
FBuffer := TStringlist.Create;
for Filename in TDirectory.GetFiles(FSearchPath, TSearchOption.soAllDirectories, nil) do
FBuffer.Add(Filename);
Synchronize(nil,
procedure
begin
FResultBuffer.Assign(FBuffer);
end);
FreeAndNil(FBuffer);
end;
This thread you have to call in a bit diffent way.
The form setup i still the same as before: A Listbox on a Form.
type
TForm1 = class(TForm)
ListBox1: TListBox;
procedure FormCreate(Sender: TObject);
private
Stopwatch: TStopwatch;
procedure SearchThreadTerminate(Sender: TObject);
public
{ Public declarations }
end;
And then the implementation:
procedure TForm1.FormCreate(Sender: TObject);
begin
Stopwatch := TStopwatch.StartNew;
with TSearchThread.Create('C:\Program Files (x86)\Embarcadero\', ListBox1.Items) do
OnTerminate := SearchThreadTerminate;
end;
procedure TForm1.SearchThreadTerminate(Sender: TObject);
begin
Stopwatch.Stop;
Caption := 'Elapsed Milliseconds: ' + IntToStr(Stopwatch.ElapsedMilliseconds) + ' Files found: ' + IntToStr(ListBox1.Items.Count);
end;
The advantage of this version is speed. Updaing the screen is slow, and the first solution updated the screen for each file it found, while this one only updates the screen twice.
Try it out.

Related

Object serializing via RTTI doesn't work anymore

I have 2 years old project which I am rebooting back to life. I have debug window which shows different information, and one part of them is that it serializes various google protobuf objects and shows them.
Here is how typical protobuf class looks like:
// Generated by the protocol buffer compiler. DO NOT EDIT!
// Source: message.proto
unit Poker.Protobufs.Objects.PingParams;
interface
uses
System.SysUtils,
{$IFNDEF FPC} System.Generics.Collections {$ELSE} Contnrs {$ENDIF},
pbOutput, Poker.Protobufs.Objects.Base, Poker.Protobufs.Reader, Poker.Types;
type
TPB_PingParams = class(TProtobufBaseObject)
private
const
kUptimeFieldNumber = 1;
var
FUptime: UInt32;
FHasBits: UINT32;
procedure set_has_Uptime;
procedure clear_has_Uptime;
procedure SetUptime(const AValue: UInt32);
public
constructor Create(const AFrom: TPB_PingParams; const ALightweight: Boolean = FALSE); overload;
destructor Destroy; override;
procedure LoadFromProtobufReader(const AProtobufReader: TProtobufReader; const ASize: Integer); override;
procedure MergeFrom(const AFrom: TPB_PingParams);
procedure Clear;
function IsInitialized: Boolean; override;
// required uint32 Uptime = 1;
function has_Uptime: Boolean;
procedure clear_Uptime;
property Uptime: UInt32 read FUptime write SetUptime;
end;
TPB_PingParamsList = class(TObjectList<TPB_PingParams>)
procedure Assign(const APB_PingParamsList: TList<TPB_PingParams>);
end;
implementation
uses
pbPublic;
constructor TPB_PingParams.Create(const AFrom: TPB_PingParams; const ALightweight: Boolean = FALSE);
begin
inherited Create(ALightweight);
MergeFrom(AFrom);
end;
destructor TPB_PingParams.Destroy;
begin
inherited;
end;
procedure TPB_PingParams.LoadFromProtobufReader(const AProtobufReader: TProtobufReader; const ASize: Integer);
var
tag, field_number, wire_type, endpos: Integer;
begin
endpos := AProtobufReader.getPos + ASize;
while (AProtobufReader.getPos < endpos) and
(AProtobufReader.GetNext(tag, wire_type, field_number)) do
case field_number of
kUptimeFieldNumber: begin
Assert(wire_type = WIRETYPE_VARINT);
FUptime := AProtobufReader.readUInt32;
set_has_Uptime;
end;
else
AProtobufReader.skipField(tag);
end;
end;
procedure TPB_PingParams.MergeFrom(const AFrom: TPB_PingParams);
begin
if AFrom.has_Uptime then
SetUptime(AFrom.Uptime);
end;
function TPB_PingParams.IsInitialized: Boolean;
begin
if (FHasBits and $1) <> $1 then
Exit(FALSE);
Exit(TRUE);
end;
procedure TPB_PingParams.clear_Uptime;
begin
FUptime := 0;
clear_has_Uptime;
end;
function TPB_PingParams.has_Uptime: Boolean;
begin
result := (FHasBits and 1) > 0;
end;
procedure TPB_PingParams.set_has_Uptime;
begin
FHasBits := FHasBits or 1;
end;
procedure TPB_PingParams.clear_has_Uptime;
begin
FHasBits := FHasBits and not 1;
end;
procedure TPB_PingParams.SetUptime(const AValue: UInt32);
begin
if not Lightweight then
Assert(not has_Uptime);
FUptime := AValue;
if not Lightweight then
ProtobufOutput.writeUInt32(kUptimeFieldNumber, AValue);
set_has_Uptime;
end;
procedure TPB_PingParams.Clear;
begin
if FHasBits = 0 then
Exit;
clear_Uptime;
end;
procedure TPB_PingParamsList.Assign(const APB_PingParamsList: TList<TPB_PingParams>);
var
pbobj: TPB_PingParams;
begin
Clear;
for pbobj in APB_PingParamsList do
Add(TPB_PingParams.Create(pbobj, TRUE));
end;
end.
And my serialization function:
function SerializeObject(const AObject: TObject): String;
var
t: TRttiType;
p: TRttiProperty;
properties: TArray<TRttiProperty>;
method: TRttiMethod;
begin
result := '';
if not Assigned(AObject) then
Exit;
t := TRttiContext.Create.GetType(AObject.ClassType);
properties := t.GetProperties;
for p in properties do
begin
method := t.GetMethod(Format('has_%s', [p.Name]));
if (Assigned(method)) and
(method.Invoke(AObject, []).AsBoolean) then
result := result + Format('%s: %s; ', [p.Name, ValueToStr(p, p.GetValue(AObject))]);
end;
end;
It is specifically designed to serialize fields that begin with has_ in protobuf objects. Now, I didn't change anything in the code over last 2 years, and this was working before. But now it doesn't. Line properties = t.GetProperties returns empty array for my protobuf classes.
My guess is that I had some globally defined compiler directive which allowed me to serialize public methods in the class. But I cannot figure out which one.
If I put {$M+} in front of my protobuf classes, and move methods to published, it works (kinda). But this worked before just like it is shown in the sources, without any {$M+} directives or similar. So I'm curious what I miss.
Compiler is same as before, XE2.

Access violation assigning autocomplete strings to

I am modifying the edit control with autocomplete from here:
Auto append/complete from text file to an edit box delphi
I want to load autocomplete strings from DB. I declared new properties on autocomplete control descendant:
FACDataSource : TDataSource;
FACFieldName : string;
I call this to load autocomplete strings:
procedure TAutoCompleteEdit.ReadSuggestions;
begin
FAutoCompleteSourceList.Clear;
if (not Assigned(FACDataSource)) or (not Assigned(FACDataSource.DataSet)) or (not ACEnabled) then
exit;
with FACDataSource.DataSet do
begin
if Active and (RecordCount > 0) and (FACFieldName <> '') then
begin
First;
while not EOF do
begin
FAutoCompleteSourceList.Add(FACDataSource.DataSet.FieldByName(FACFieldName).AsString);
Next;
end;
if FAutoCompleteSourceList.Count > 0 then
ACStrings := FAutoCompleteSourceList;
end;
end;
end;
However, I get AccessViolation when assigning FAutoCompleteSourceList to ACStrings. The setter for ACStrings is:
procedure TAutoCompleteEdit.SetACStrings(const Value: TStringList);
begin
if Value <> FACList.FStrings then
FACList.FStrings.Assign(Value);
end;
I get AccessViolation in the line: FACList.FStrings.Assign(Value); (READ of address XXXYYY). Value is defined and not garbage at that point (e.g. in I can view the string list in the debugger). 'FStrings' is an empty stringlist.
It works fine when the control is dropped on the form. But doesn't if I place it within a custom inplace editor shown when user enters a DBGridEH cell.
The inplace editor is like this:
unit UInplaceAutoCompleteEditor;
interface
uses UDBAutoComplete, UMyInplaceEditor, classes, windows, Controls, Buttons, DB;
type TInplaceAutoCompleteEditor = class(TMyInplaceEditor)
private
FEditor : TAutoCompleteEdit;
FButton : TSpeedButton;
FShowButton : boolean;
procedure SetShowButton(value : boolean);
public
constructor Create(AOwner : TComponent); override;
procedure SetFocus; override;
destructor Destroy; override;
protected
procedure EditorKeyDown(Sender : TObject; var Key : Word; Shift : TShiftState);
function GetACDataSource : TDataSource;
procedure SetACDataSource(value : TDataSource);
function GetACFieldName : string;
procedure SetACFieldName(value : string);
procedure SetACEnabled(value : boolean);
function GetACEnabled : boolean;
published
property Editor : TAutoCompleteEdit read FEditor;
property ACDataSource : TDataSource read GetACDataSource write SetACDataSource;
property ACFieldName : string read GetACFieldName write SetACFieldName;
property ACEnabled : boolean read GetACEnabled write SetACEnabled;
property Button : TSpeedButton read FButton;
property ShowButton : boolean read FShowButton write SetShowButton;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('nikolaev', [ TInplaceAutoCompleteEditor ]);
end;
{ TInplaceAutoCompleteEditor }
constructor TInplaceAutoCompleteEditor.Create(AOwner: TComponent);
begin
inherited;
FEditor := TAutoCompleteEdit.Create(self);
FEditor.Parent := self;
FEditor.Align := alClient;
FEditor.Visible := true;
FEditor.WantTabs := true;
FEditor.OnKeyDown := EditorKeyDown;
FButton := TSpeedButton.Create(self);
FButton.Parent := self;
FButton.Align := alRight;
self.FOwnHeight := -1;
self.FOwnWidth := -1;
SetShowButton(false);
end;
destructor TInplaceAutoCompleteEditor.Destroy;
begin
Feditor.Destroy;
FButton.Destroy;
inherited;
end;
procedure TInplaceAutoCompleteEditor.EditorKeyDown(Sender: TObject;
var Key: Word; Shift: TShiftState);
begin
if Key in [ VK_Return, VK_Tab ] then
begin
self.Value := FEditor.Text;
Key := 0;
ConfirmValue;
end;
if Key = VK_Escape then
begin
Key := 0;
CancelValue;
end;
inherited;
end;
function TInplaceAutoCompleteEditor.GetACDataSource: TDataSource;
begin
Result := FEditor.ACDataSource;
end;
function TInplaceAutoCompleteEditor.GetACEnabled: boolean;
begin
Result := FEditor.ACEnabled;
end;
function TInplaceAutoCompleteEditor.GetACFieldName: string;
begin
Result := FEditor.ACFieldName
end;
procedure TInplaceAutoCompleteEditor.SetACDataSource(value: TDataSource);
begin
FEditor.ACDataSource := value;
end;
procedure TInplaceAutoCompleteEditor.SetACEnabled(value: boolean);
begin
FEditor.ACEnabled := value;
end;
procedure TInplaceAutoCompleteEditor.SetACFieldName(value: string);
begin
FEditor.acfieldname := value;
end;
procedure TInplaceAutoCompleteEditor.SetFocus;
begin
inherited;
FEditor.SetFocus;
end;
procedure TInplaceAutoCompleteEditor.SetShowButton(value: boolean);
begin
if value <> FShowButton then
begin
FShowButton := value;
FButton.Visible := value;
end;
end;
end.
This inplace editor inherits from an abstract class like this:
unit UMyInplaceEditor;
interface
uses Windows, classes, types, dbGridEh, ExtCtrls, Controls;
type TMyInplaceEditor = class (TWinControl)
private
FOnValueConfirmed : TNotifyEvent;
FOnCanceled : TNotifyEvent;
FWantTabs : boolean;
procedure AdjustPosition;
protected
FOwnHeight, FOwnWidth : integer;
FValue : Variant;
function GetIsEditing : boolean;
procedure SetIsEditing(value : boolean); virtual;
procedure ConfirmValue;
procedure CancelValue;
procedure SetValue(val : Variant); virtual;
public
property OnValueConfirmed : TNotifyEvent read FOnValueConfirmed write FOnValueConfirmed;
property OnCanceled : TNotifyEvent read FOnCanceled write FOnCanceled;
property Value : Variant read FValue write SetValue;
property IsEditing : boolean read GetIsEditing write SetIsEditing;
procedure SetPosition(parentControl : TWinControl; rect : TRect); virtual;
function ColumnEditable(column : TColumnEH) : boolean; virtual;
constructor Create(AOwner : TComponent); override;
property WantTabs : boolean read FWantTabs write FWantTabs;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('nikolaev', [TMyInplaceEditor]);
end;
constructor TMyInplaceEditor.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
self.AutoSize := false;
self.Visible := false;
self.FOwnHeight := -1;
self.FOwnWidth := -1;
end;
procedure TMyInplaceEditor.AdjustPosition;
var xOffset, yOffset : integer;
begin
xoffset := self.Left + self.Width - self.Parent.Width;
if xOffset > 0 then
self.Left := self.Left - xOffset;
yOffset := self.Top + self.Height - self.Parent.height;
if yOffset > 0 then
self.Top := self.Top - yOffset;
end;
function TMyInplaceEditor.GetIsEditing : boolean;
begin
Result := self.Visible;
end;
procedure TMyInplaceEditor.SetIsEditing(value: Boolean);
begin
self.Visible := value;
self.BringToFront;
{if Visible then
self.SetFocus;}
end;
procedure TMyInplaceEditor.SetPosition(parentControl : TWinControl; rect: TRect);
begin
self.Parent := parentControl;
self.Top := rect.Top;//parentControl.Top;
self.Left := rect.Left;//parentControl.left;
if self.FOwnWidth = -1 then
self.Width := rect.Right - rect.Left
else
self.Width := self.FOwnWidth;
if self.FOwnHeight = -1 then
self.Height := rect.Bottom - rect.Top
else
self.Height := self.FOwnHeight;
AdjustPosition;
end;
function TMyInplaceEditor.ColumnEditable(column : TColumnEH) : boolean;
begin
Result := true;
end;
procedure TMyInplaceEditor.ConfirmValue;
begin
if Assigned(FOnValueConfirmed) then
FOnValueConfirmed(self);
end;
procedure TMyInplaceEditor.CancelValue;
begin
if Assigned(FOnCanceled) then
FOnCanceled(self);
end;
procedure TMyInplaceEditor.SetValue(val : Variant);
begin
FValue := val;
end;
end.
The InplaceEditor is used in a descendant from DBGridEH. I override ShowEditor and HideEditor to show / hide my editor in certain cases.
Again, the autocomplete control only throws exception when embedded in the inplaceeditor control.
What causes access violation?
The problem is that the code you are using mis-handles interface reference counting. Here are the relevant extracts:
type
TEnumString = class(TInterfacedObject, IEnumString)
....
Note that this class is derived from TInterfacedObject and so it manages its lifetime using reference counting.
Then the code goes on like this:
type
TAutoCompleteEdit = class(TEdit)
private
FACList: TEnumString;
....
So we are going to hold a reference to the object rather than the interface. That looks dubious already.
Then we do this:
constructor TAutoCompleteEdit.Create(AOwner: TComponent);
begin
inherited;
FACList := TEnumString.Create;
....
end;
destructor TAutoCompleteEdit.Destroy;
begin
FACList := nil;
inherited;
end;
There's nothing here to keep the object alive. At other points in the code we take a reference to the IEnumString interface. But then as soon as that reference is released, the object thinks that there are no references left. And so it is deleted. Then, later on, the code refers to FACList which now points at an object that has been destroyed.
A simple way to fix this would be to make sure that the TAutoCompleteEdit control always holds a reference to the interface:
type
TAutoCompleteEdit = class(TEdit)
private
FACList: TEnumString;
FEnumString: IEnumString;
....
constructor TAutoCompleteEdit.Create(AOwner: TComponent);
begin
inherited;
FACList := TEnumString.Create;
FEnumString := FACList;
....
end;
And with this change you can then remove the destructor for TAutoCompleteEdit since the object behind FEnumString will get destroyed by the reference counting mechanism.
Another way to fix this would be to change TEnumString to disable automatic reference counting. That would look like this:
type
TEnumString = class(TObject, IInterface, IEnumString)
private
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
....
end;
function TEnumString.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
if GetInterface(IID, Obj) then
Result := 0
else
Result := E_NOINTERFACE;
end;
function TEnumString._AddRef: Integer;
begin
Result := -1;
end;
function TEnumString._Release: Integer;
begin
Result := -1;
end;
And then you'd need the TAutoCompleteEdit destructor to look like this:
destructor TAutoCompleteEdit.Destroy;
begin
FACList.Free;
inherited;
end;
And a final option would be to avoid holding a TEnumString at all and instead only hold an IEnumString reference. Let the reference counting manage lifetime as in the first solution. But then you'd need to implement another interface that allowed the TAutoCompleteEdit to obtain the TStrings object.

Keep values from the beforepost event to the afterpost event

I am writing this question for Delphi 2007, but I'm pretty sure that this is a common problem in all kind of languages.
So, I have a project where I need to keep informations about the old and new value of certain fields (which are given in the BeforePost event of the dataset I'm working with) and use them in the AfterPost event.
For now, I have been using global variables, but there is already so many of them in the project that this is becoming a real issue when it comes to managing documentation and/or comments.
Basically, I am asking if there is a better way (in Delphi 2007 or in general) to keep the informations from the BeforePost event of a Dataset and get them back in the AfterPost event.
first create a new Custom Data Source
TDataRecord = array of record
FieldName: string;
FieldValue: Variant;
end;
TMyDataSource = class(TDataSource)
private
LastValues: TDataRecord;
procedure MyDataSourceBeforePost(DataSet: TDataSet);
procedure SetDataSet(const Value: TDataSet);
function GetDataSet: TDataSet;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetLastValue(FieldName: string): Variant;
property MyDataSet: TDataSet read GetDataSet write SetDataSet;
end;
{ TMyDataSource }
constructor TMyDataSource.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
end;
destructor TMyDataSource.Destroy;
begin
SetLength(LastValues, 0);
inherited Destroy;
end;
function TMyDataSource.GetDataSet: TDataSet;
begin
Result := DataSet;
end;
procedure TMyDataSource.SetDataSet(const Value: TDataSet);
begin
DataSet := Value;
DataSet.BeforePost := MyDataSourceBeforePost;
end;
procedure TMyDataSource.MyDataSourceBeforePost(DataSet: TDataSet);
var
i: integer;
begin
SetLength(LastValues, DataSet.FieldCount);
for i:=0 to DataSet.FieldCount-1 do
begin
LastValues[i].FieldName := DataSet.Fields.Fields[i].FieldName;
LastValues[i].FieldValue := DataSet.Fields.Fields[i].OldValue;
end;
end;
function TMyDataSource.GetLastValue(FieldName: string): Variant;
var
i: integer;
begin
Result := Null;
for i:=0 to Length(LastValues)-1 do
if SameText(FieldName, LastValues[i].FieldName) then
begin
Result := LastValues[i].FieldValue;
break;
end;
end;
and after override application Data Source
TForm1 = class(TForm)
private
MyDataSource: TMyDataSource;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
ADOQuery1.Active := true;
MyDataSource := TMyDataSource.Create(Self);
MyDataSource.MyDataSet := ADOQuery1;
DBGrid1.DataSource := MyDataSource;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
MyDataSource.Free;
end;
procedure TForm1.ADOQuery1AfterPost(DataSet: TDataSet);
var
AValue: Variant;
begin
AValue := MyDataSource.GetLastValue('cname');
if not VarIsNull(AValue) then;
end;

How to copy the properties of one class instance to another instance of the same class?

I want to duplicate a class. It is sufficient that I copy all properties of that class. Is it possible to:
loop thru all properties of a class?
assign each property to the other property, like a.prop := b.prop?
The getters and setters should take care of the underlying implementation details.
EDIT:
As Francois pointed out I did not word my question carefully enough. I hope the new wording of the question is better
SOLUTION:
Linas got the right solution. Find a small demo program below. Derived classes work as expected. I didn't know about the new RTTI possibilities until several people pointed me at it. Very useful information. Thank you all.
unit properties;
interface
uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls,
RTTI, TypInfo;
type
TForm1 = class(TForm)
Memo1: TMemo;
Button0: TButton;
Button1: TButton;
procedure Button0Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
public
procedure GetObjectProperties (AObject: TObject; AList: TStrings);
procedure CopyObject<T: class>(ASourceObject, ATargetObject: T);
end;
TDemo = class (TObject)
private
FIntField: Int32;
function get_str_field: string;
procedure set_str_field (value: string);
public
constructor Create; virtual;
property IntField: Int32 read FIntField write FIntField;
property StrField: string read get_str_field write set_str_field;
end; // Class: TDemo //
TDerived = class (TDemo)
private
FList: TStringList;
function get_items: string;
procedure set_items (value: string);
public
constructor Create; override;
destructor Destroy; override;
procedure add_string (text: string);
property Items: string read get_items write set_items;
end;
var Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.GetObjectProperties(AObject: TObject; AList: TStrings);
var ctx: TRttiContext;
rType: TRttiType;
rProp: TRttiProperty;
AValue: TValue;
sVal: string;
const SKIP_PROP_TYPES = [tkUnknown, tkInterface];
begin
if not Assigned(AObject) and not Assigned(AList) then Exit;
ctx := TRttiContext.Create;
rType := ctx.GetType(AObject.ClassInfo);
for rProp in rType.GetProperties do
begin
if (rProp.IsReadable) and not (rProp.PropertyType.TypeKind in SKIP_PROP_TYPES) then
begin
AValue := rProp.GetValue(AObject);
if AValue.IsEmpty then
begin
sVal := 'nil';
end else
begin
if AValue.Kind in [tkUString, tkString, tkWString, tkChar, tkWChar]
then sVal := QuotedStr(AValue.ToString)
else sVal := AValue.ToString;
end;
AList.Add(rProp.Name + '=' + sVal);
end;
end;
end;
procedure TForm1.CopyObject<T>(ASourceObject, ATargetObject: T);
const
SKIP_PROP_TYPES = [tkUnknown, tkInterface, tkClass, tkClassRef, tkPointer, tkProcedure];
var
ctx: TRttiContext;
rType: TRttiType;
rProp: TRttiProperty;
AValue, ASource, ATarget: TValue;
begin
Assert( Assigned(ASourceObject) and Assigned(ATargetObject) , 'Both objects must be assigned');
ctx := TRttiContext.Create;
rType := ctx.GetType(ASourceObject.ClassInfo);
ASource := TValue.From<T>(ASourceObject);
ATarget := TValue.From<T>(ATargetObject);
for rProp in rType.GetProperties do
begin
if (rProp.IsReadable) and (rProp.IsWritable) and not (rProp.PropertyType.TypeKind in SKIP_PROP_TYPES) then
begin
//when copying visual controls you must skip some properties or you will get some exceptions later
if SameText(rProp.Name, 'Name') or (SameText(rProp.Name, 'WindowProc')) then
Continue;
AValue := rProp.GetValue(ASource.AsObject);
rProp.SetValue(ATarget.AsObject, AValue);
end;
end;
end;
procedure TForm1.Button0Click(Sender: TObject);
var demo1, demo2: TDemo;
begin
demo1 := TDemo.Create;
demo2 := TDemo.Create;
demo1.StrField := '1023';
Memo1.Lines.Add ('---Demo1---');
GetObjectProperties (demo1, Memo1.Lines);
CopyObject<TDemo> (demo1, demo2);
Memo1.Lines.Add ('---Demo2---');
GetObjectProperties (demo2, Memo1.Lines);
end;
procedure TForm1.Button1Click(Sender: TObject);
var derivate1, derivate2: TDerived;
begin
derivate1 := TDerived.Create;
derivate2 := TDerived.Create;
derivate1.IntField := 432;
derivate1.add_string ('ien');
derivate1.add_string ('twa');
derivate1.add_string ('drei');
derivate1.add_string ('fjour');
Memo1.Lines.Add ('---derivate1---');
GetObjectProperties (derivate1, Memo1.Lines);
CopyObject<TDerived> (derivate1, derivate2);
Memo1.Lines.Add ('---derivate2---');
GetObjectProperties (derivate2, Memo1.Lines);
end;
constructor TDemo.Create;
begin
IntField := 321;
end; // Create //
function TDemo.get_str_field: string;
begin
Result := IntToStr (IntField);
end; // get_str_field //
procedure TDemo.set_str_field (value: string);
begin
IntField := StrToInt (value);
end; // set_str_field //
constructor TDerived.Create;
begin
inherited Create;
FList := TStringList.Create;
end; // Create //
destructor TDerived.Destroy;
begin
FList.Free;
inherited Destroy;
end; // Destroy //
procedure TDerived.add_string (text: string);
begin
FList.Add (text);
end; // add_string //
function TDerived.get_items: string;
begin
Result := FList.Text;
end; // get_items //
procedure TDerived.set_items (value: string);
begin
FList.Text := value;
end; // set_items //
end. // Unit: properties //
Try this code (but I won't advise copying properties of visual components because then you'll need to manually skip some properties):
uses
Rtti, TypInfo;
procedure CopyObject<T: class>(ASourceObject, ATargetObject: T);
procedure TForm1.CopyObject<T>(ASourceObject, ATargetObject: T);
const
SKIP_PROP_TYPES = [tkUnknown, tkInterface, tkClass, tkClassRef, tkPointer, tkProcedure];
var
ctx: TRttiContext;
rType: TRttiType;
rProp: TRttiProperty;
AValue, ASource, ATarget: TValue;
begin
Assert( Assigned(ASourceObject) and Assigned(ATargetObject) , 'Both objects must be assigned');
ctx := TRttiContext.Create;
rType := ctx.GetType(ASourceObject.ClassInfo);
ASource := TValue.From<T>(ASourceObject);
ATarget := TValue.From<T>(ATargetObject);
for rProp in rType.GetProperties do
begin
if (rProp.IsReadable) and (rProp.IsWritable) and not (rProp.PropertyType.TypeKind in SKIP_PROP_TYPES) then
begin
//when copying visual controls you must skip some properties or you will get some exceptions later
if SameText(rProp.Name, 'Name') or (SameText(rProp.Name, 'WindowProc')) then
Continue;
AValue := rProp.GetValue(ASource.AsObject);
rProp.SetValue(ATarget.AsObject, AValue);
end;
end;
end;
Usage example:
CopyObject<TDemoObj>(FObj1, FObj2);
Your question as it is does not make much sense to me.
Are you really trying to create a new class by copying an existing one?
Or are you trying to do a deep copy of an instance A of a class into another instance B of the same class?
In that case, see this discussion about cloning in another SO question.
You didn't mention your Delphi version, but here's a good start. You need to explore the Delphi RTTI which allows you to obtain runtime type information. You'd have to iterate your source class for types, then provide a method for assigning each type.
About RTTI
If you're designing your own simple classes, you could just override assign and do your own property assignments there.

Creating replacement TApplication for experimentation?

I got the crazy idea one day to make a completely new replacement of TApplication for experimentation. I got everything to compile and run, and it does show the main form properly, everything responds good, but upon closing the form, the application does not halt. I'm sure I copied all the necessary stuff from the original Forms.pas TApplication (registering close event) but I don't see it working. I have to terminate the debug session the nasty way.
My goal in this little experiment is to build a lightweight application for very simple things instead of all the possible things a TApplication can handle, and also mostly so I have some good experience in such a field.
Here's the unit as I have it now, and below is the implementation of it.
unit JDForms;
interface
uses
Forms, Classes, SysUtils, StrUtils, Windows, Win7, XPMan, Variants,
Messages, Dialogs;
type
TJDForm = class;
TJDApplication = class;
TJDApplicationThread = class;
TJDForm = class(TCustomForm)
private
public
published
end;
TJDApplication = class(TComponent)
private
fRunning: Bool;
fTerminated: Bool;
fThread: TJDApplicationThread;
fMainForm: TJDForm;
fOnMessage: TMessageEvent;
fShowMainForm: Bool;
fHandle: HWND;
procedure ThreadTerminated(Sender: TObject);
procedure HandleMessage;
procedure ProcessMessages;
function ProcessMessage(var Msg: TMsg): Boolean;
procedure ThreadSync(Sender: TObject);
public
constructor Create(AOwner: TComponent); override;
property Thread: TJDApplicationThread read fThread;
procedure Initialize;
procedure Run;
procedure CreateForm(InstanceClass: TComponentClass; var Reference);
procedure Terminate;
property Terminated: Bool read fTerminated;
procedure HandleException(Sender: TObject);
property Handle: HWND read fHandle;
published
property ShowMainForm: Bool read fShowMainForm write fShowMainForm;
property OnMessage: TMessageEvent read fOnMessage write fOnMessage;
end;
TJDApplicationThread = class(TThread)
private
fOwner: TJDApplication;
fStop: Bool;
fOnSync: TNotifyEvent;
procedure DoSync;
protected
procedure Execute; override;
public
constructor Create(AOwner: TJDApplication);
destructor Destroy; override;
procedure Start;
procedure Stop;
published
property OnSync: TNotifyEvent read fOnSync write fOnSync;
end;
var
JDApplication: TJDApplication;
implementation
procedure DoneApplication;
begin
with JDApplication do begin
if Handle <> 0 then ShowOwnedPopups(Handle, False);
//ShowHint := False;
Destroying;
DestroyComponents;
end;
end;
{ TJDApplication }
constructor TJDApplication.Create(AOwner: TComponent);
begin
fRunning:= False;
fTerminated:= False;
fMainForm:= nil;
fThread:= TJDApplicationThread.Create(Self);
fThread.FreeOnTerminate:= True;
fThread.OnTerminate:= ThreadTerminated;
fShowMainForm:= True;
end;
procedure TJDApplication.CreateForm(InstanceClass: TComponentClass; var Reference);
var
Instance: TComponent;
begin
Instance:= TComponent(InstanceClass.NewInstance);
TComponent(Reference) := Instance;
try
Instance.Create(Self);
except
TComponent(Reference):= nil;
raise;
end;
if (fMainForm = nil) and (Instance is TForm) then begin
TForm(Instance).HandleNeeded;
fMainForm:= TJDForm(Instance);
end;
end;
procedure TJDApplication.HandleException(Sender: TObject);
begin
{
if GetCapture <> 0 then SendMessage(GetCapture, WM_CANCELMODE, 0, 0);
if ExceptObject is Exception then
begin
if not (ExceptObject is EAbort) then
if Assigned(FOnException) then
FOnException(Sender, Exception(ExceptObject))
else
ShowException(Exception(ExceptObject));
end else
SysUtils.ShowException(ExceptObject, ExceptAddr);
}
end;
procedure TJDApplication.HandleMessage;
var
Msg: TMsg;
begin
if not ProcessMessage(Msg) then begin
//Idle(Msg);
end;
end;
function TJDApplication.ProcessMessage(var Msg: TMsg): Boolean;
var
Handled: Boolean;
begin
Result := False;
if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then
begin
Result := True;
if Msg.Message <> WM_QUIT then begin
Handled := False;
if Assigned(FOnMessage) then FOnMessage(Msg, Handled);
//if not IsHintMsg(Msg) and not Handled and not IsMDIMsg(Msg) and
//not IsKeyMsg(Msg) and not IsDlgMsg(Msg) then
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end else begin
fTerminated:= True;
end;
end;
end;
procedure TJDApplication.ProcessMessages;
var
Msg: TMsg;
begin
while ProcessMessage(Msg) do {loop};
end;
procedure TJDApplication.Initialize;
begin
if InitProc <> nil then TProcedure(InitProc);
end;
procedure TJDApplication.Run;
begin {
fRunning := True;
try
AddExitProc(DoneApplication);
if FMainForm <> nil then
begin
case CmdShow of
SW_SHOWMINNOACTIVE: FMainForm.FWindowState := wsMinimized;
SW_SHOWMAXIMIZED: MainForm.WindowState := wsMaximized;
end;
if FShowMainForm then
if FMainForm.FWindowState = wsMinimized then
Minimize else
FMainForm.Visible := True;
repeat
try
HandleMessage;
except
HandleException(Self);
end;
until Terminated;
end;
finally
FRunning := False;
end;
}
fRunning:= True;
try
AddExitProc(DoneApplication);
if fMainForm <> nil then begin
fHandle:= fMainForm.Handle;
if fShowMainForm then begin
fMainForm.Show;
end;
fThread.Start;
repeat
try
HandleMessage;
//--- THREAD HANDLING MESSAGES ---
except
HandleException(Self);
end;
until fTerminated;
end else begin
//Main form is nil - can not run
end;
finally
fRunning:= False;
fTerminated:= True;
end;
end;
procedure TJDApplication.Terminate;
begin
fTerminated:= True;
try
fThread.Stop;
except
end;
if CallTerminateProcs then PostQuitMessage(0);
end;
procedure TJDApplication.ThreadTerminated(Sender: TObject);
begin
//Free objects
end;
procedure TJDApplication.ThreadSync(Sender: TObject);
var
Msg: TMsg;
begin
if not ProcessMessage(Msg) then begin
//Idle(Msg);
end;
end;
{ TJDApplicationThread }
constructor TJDApplicationThread.Create(AOwner: TJDApplication);
begin
inherited Create(True);
fOwner:= AOwner;
end;
destructor TJDApplicationThread.Destroy;
begin
inherited;
end;
procedure TJDApplicationThread.DoSync;
begin
Self.fOwner.ThreadSync(Self);
// if assigned(fOnSync) then fOnSync(Self);
end;
procedure TJDApplicationThread.Execute;
var
ST: Integer;
begin
ST:= 5;
fStop:= False;
while (not Terminated) and (not fStop) do begin
//----- BEGIN -----
Synchronize(DoSync);
//----- END -----
//Sleep(1000 * ST);
end;
end;
procedure TJDApplicationThread.Start;
begin
fStop:= False;
Resume;
end;
procedure TJDApplicationThread.Stop;
begin
fStop:= True;
Suspend;
end;
initialization
JDApplication:= TJDApplication.Create(nil);
finalization
if assigned(JDApplication) then begin
JDApplication.Free;
JDApplication:= nil;
end;
end.
And here's an application using this:
program Win7FormTestD7;
uses
Forms,
W7Form1 in 'W7Form1.pas' {Win7Form1},
JDForms in 'JDForms.pas';
begin
JDApplication.Initialize;
JDApplication.CreateForm(TWin7Form1, Win7Form1);
JDApplication.Run;
end.
The form 'W7Form1' is just a plain form with a couple random controls on it to test with.
Users here should not ask the question of why I want to do this, I have my reasons. I learn by doing, not by someone showing me or by reading some book or finding a bunch of code which I don't know how it works. This is a way for me to better learn the workings of applications and be able to expand my knowledge in the field to be able to build more complex applications in the future.
Keep in mind that TCustomForm has no concept of your TJDApplication class, it only works with the Forms.TApplication class instead. Make sure your TJDApplication.Run() method is exiting when the Forms.TApplication.Terminated property has been set to True.
If building lightweight application is your motto, I suggest you to play around with :
The KOL Library
The SDA Framework
VCL Light by Paul TOTH
LVCL based on VCL Light code by SO member Arnaud Bouchez.

Resources