delphi Form with multi instance use - delphi

i've an FTP uploader project that uses a form created on run time to start uploading to multiple FTP Servers ( using Indy ) , my issue is as follows ( and i really need your help ) .
On a Form i put an IdFTP Component + an Upload button + public properties named FTPSrvAdrs and SrcFile + TrgFolder like this way :
type
TFtpUploader = class(TForm)
IdFTP: TIdFTP;
StartUpload:TButton;
UploadProgress:TProgressBar;
procedure StartUploadClick(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
FFtpSrvAdrs:String;
FSrcFile:String;
FTargetFtpFld:String;
Procedure StartMyUpload();
procedure SetFtpAdrs(const value:string);
procedure SetSrcFile(const value:string);
procedure SetTargetFtpFld(const value:string);
{ Private declarations }
public
{ Public declarations }
property FtpAdrs:string read FFtpSrvAdrs write SetFtpAdrs;
property SourceFile:string read FSrcFile write SetSrcFile;
property TargetFtpFld:string read FTargetFtpFld write SetTargetFtpFld;
end;
var
FtpUploader: TFtpUploader;
implementation
procedure TFtpUploader.StartUploadClick(Sender: TObject);
begin
StartMyUpload();
end;
procedure TFtpUploader.SetFtpAdrs(const value: string);
begin
FFtpSrvAdrs:=value;
end;
procedure TFtpUploader.SetSrcFile(const value: string);
begin
FSrcFile:=value;
end;
procedure TFtpUploader.SetTargetFtpFld(const value: string);
begin
FTargetFtpFld:=value;
end;
procedure TFtpUploader.StartMyUpload;
var
FtpUpStream: TFileStream;
begin
ftpUpStream:= TFileStream.create(FSrcFile, fmopenread)
try
with IdFTP do begin
Host:= FFtpSrvAdrs;
Username:='MyUserName';
Password:='MyPassword';
end;
IdFTP.Connect(true, 1200)
IdFTP.Passive:= true;
IdFTP.ChangeDir(FTargetFtpFld)
IdFTP.Put(ftpUpStream,FSrcFile, false);
finally
ftpUpStream.Free;
end;
end;
procedure TFtpUploader.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action:=caFree;
end;
This Form will be created on RunTime ( 4 times = 4 buttons will launch it separately like this way :
in the main form i've this procedure :
Procedure MainForm.UploadTo(FTPSrv,SrcFile,FtpTargetFld:String);
var
FUploadFrm:TFtpUploader;
begin
FUploadFrm:=TFtpUploader.Create(nil);
if assigned(FUploadFrm) then
begin
FUploadFrm.FtpAdrs:=FTPSrv;
FUploadFrm.SourceFile:=SrcFile;
FUploadFrm.TargetFtpFld:=FtpTargetFld;
FUploadFrm.Show;
end;
end;
procedure MainForm.Button1Click(Sender: TObject);
begin
UploadTo('MyFtpSrv_1','MySrcFile_1','MyFtpTargetFld_1');
end;
procedure MainForm.Button2Click(Sender: TObject);
begin
UploadTo('MyFtpSrv_2','MySrcFile_2','MyFtpTargetFld_2');
end;
// same with other 2 buttons
the FtpUploader form is Created / Opened ( 4 instances ) ,The ISSUE IS when i click on StartUpload button the FTP upload process is not started on all these 4 instances , but i've to wait each upload process is done ( finished ) and the other will auto-start , that means not all upload processes are started in same time .
Thank you .

It seems you have to either change Indy library for some non-blocking in-background library (event based or completion port based), or to make your program multi-threading (with it's own bunch of problems like user clicking a button 20 times or closing the form while the process is going, or even closing the program on the run).
Based on http://otl.17slon.com/book/doku.php?id=book:highlevel:async it can look anything like this:
TFtpUploader = class(TForm)
private
CanCloseNow: boolean;
...
procedure TFtpUploader.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if Self.CanCloseNow
then Action := caFree
else Action := caIgnore;
end;
procedure TFtpUploader.MyUploadComplete;
begin
Self.CanCloseNow := True;
Self.Close;
end;
procedure TFtpUploader.StartMyUpload;
begin
Self.CanCloseNow := false;
Self.Enabled := False;
Self.Visible := True;
Application.ProcessMessages;
Parallel.Async(
procedure
var
FtpUpStream: TFileStream;
begin
ftpUpStream:= TFileStream.create(FSrcFile, fmopenread)
try
with IdFTP do begin
Host:= FFtpSrvAdrs;
Username:='MyUserName';
Password:='MyPassword';
Connect(true, 1200)
Passive:= true;
ChangeDir(FTargetFtpFld)
// this does not return until uploaded
// thus would not give Delphi a chance to process buttons
// pressed on other forms.
Put(ftpUpStream,FSrcFile, false);
end;
finally
ftpUpStream.Free;
end;
end
,
Parallel.TaskConfig.OnTerminated(
procedure (const task: IOmniTaskControl)
begin
MyUploadComplete;
end;
);
end;
Or you can use simplier AsyncCalls library http://andy.jgknet.de/blog/bugfix-units/asynccalls-29-asynchronous-function-calls/

Related

Delphi FireDac application blocking with unavailable host

Source: Delphi XE10; Os: W10; Database server: FB 2_5_1;
I created client application to connect more than one database. My application create TSource->Create TThread -> create DataModule with FDConnection.
Every TSource have own TThread which have own DataModule;
To tests I have two definitions: HostLocal and HostRemote;
My Test:
a)Run: Connection.Open for HostRemote;
b)Next Run: Connection.Open for HostLocal;
When HostRemote is unavailable than HostLocal wait for I dont know for what.
Why unavailable connection blocked another correct connection?
EDIT:
Database Server was updated to 3.0.0
Code:
begin
Application.Initialize;
Application.CreateForm(TFormMain, FormMain);
Application.Run;
end.
unit UnitFormMain;
procedure TFormMain.FormCreate(Sender: TObject);
begin
Source0 := TFormSource.Create(Self);
Source1 := TFormSource.Create(Self);
end;
procedure TFormMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
FreeAndNil( Source0 );
FreeAndNil( Source1 );
end;
procedure TFormMain.Button1Click(Sender: TObject);
begin
Source0.Show;
Source1.Show;
Source0.ThStart( 0 );
Source1.ThStart( 1 );
end;
unit UnitFormSource;
TFormSource = class(TForm)
Memo: TMemo;
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
th: TMyThread;
public
procedure ThStart( value: Integer );
procedure MyTerminate( Sender: TObject );
end;
...
procedure TFormSource.FormCreate(Sender: TObject);
begin
th := TMyThread.Create( TRUE );
th.OnTerminate := MyTerminate;
th.Priority := TThreadPriority.tpLower;
th.FreeOnTerminate := TRUE;
end;
procedure TFormSource.FormClose(Sender: TObject; var Action: TCloseAction);
begin
FreeAndNil( th );
Action := TCloseAction.caFree;
end;
procedure TFormSource.ThStart(value: Integer);
begin
th.SetSwitch( value );
th.Resume;
Memo.Lines.Add( TimeToStr(Now) + ' Start' );
end;
procedure TFormSource.MyTerminate(Sender: TObject);
begin
Memo.Lines.Add( TimeToStr(Now) + ' Terminate' );
end;
unit UnitThread;
TMyThread = class(TThread)
private
Switch: Integer;
dm: TDMFireBird;
protected
procedure Execute; override;
public
constructor Create(CreateSuspended: Boolean);
destructor Destroy; override;
procedure SetSwitch(value: Integer);
end;
...
constructor TMyThread.Create(CreateSuspended: Boolean);
begin
inherited Create(CreateSuspended);
dm := TDMFireBird.Create(nil);
Switch := -1;
end;
destructor TMyThread.Destroy;
begin
FreeAndNil(dm);
inherited;
end;
procedure TMyThread.Execute;
begin
with dm.FDConnection.Params do
begin
Clear;
Add('DriverID=FB');
end;
case Switch of
0:
with dm.FDConnection.Params do
Add('Protocol=Local');
1:
with dm.FDConnection.Params do
begin
Add('Protocol=TCPIP');
Add('Server=10.0.0.1'); // unavailable connection - server not exist
Add('Port=3050');
end;
end;
with dm.FDConnection.Params do
begin
Add('Database=D:\temp\test.fdb');
Add('User_Name=SYSDBA');
Add('Password=masterkey');
end;
try
dm.FDConnection.Open;
except
// to-do: update error message
end;
end;
procedure TMyThread.SetSwitch(value: Integer);
begin
Switch := value;
end;
unit UnitDMFireBird;
TDMFireBird = class(TDataModule)
FDConnection: TFDConnection;
FDTransaction: TFDTransaction;
private
{ Private declarations }
public
{ Public declarations }
end;
Test no.1
Code:
Source0.ThStart( 0 );
// Source1.ThStart( 1 );
Result for Source0:
14:46:20 Start
14:46:20 Terminate
Result for Source1: no result
Comment: At the same time first connection was opened;
Test no.2
Code:
Source0.ThStart( 0 );
Source1.ThStart( 1 );
Result for Source0:
14:48:16 Start
14:48:40 Terminate
Result for Source1:
14:48:16 Start
14:48:40 Terminate
Comment: Terminate for both at the same time.
My question. Why one blocked another ? Why (for test no.2) first correct connection wait for second unavailable connection? In test no.2 first connection should to open like in test no.1 -> fast, without wait.

Delphi Thread doesn't run [duplicate]

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.

How to create a default project under Delphi XE7?

Related to this question: Should "Library path" point to the source files of packages?
Fabricio Araujo suggested that is not necessary to set the 'search path' for each new project by creating a 'Default Project Option'. How can this be done in Delphi XE7?
Prompted by your q, and more for amusement than anything else, I decided to try
writing an IDE-plugin that would provide a way to store some preferred project
settings somewhere and allow you to apply them to the current project.
To use, prepare and save a sample .Ini file containing your preferred settings in the format shown below (it's important to get the project option names right, see below for how to do find them out), then compile the unit below into a new package and install it in the IDE. Its gui will pop up when you subsequently open a project.
The settings in the .Ini are loaded into a ValueList editor and pressing the
[Return] key in one of the values will apply it to the project.
Interestingly, the names the IDE uses for the Project seetings are the same in XE7
as they are in D7. Iow, the XE7 IDE uses these internally rather than the names
which appear in the .DProj XML file. You can get a full list of them by clicking the GetOptions button.
As usual when working with the IDE OTA services, the code has to include
a fair amount of "baggage".
Tested in D7 and XE7.
Sample Ini File:
[settings]
OutputDir=Somewhere
UnitOutputDir=Somewhere else
UnitDir=$(DELPHI)
ObjDir=$(DELPHI)
SrcDir=$(DELPHI)
ResDir=$(DELPHI)
Code:
unit ProjectOptionsXE7u;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, ToolsAPI, Grids, ValEdit, IniFiles;
type
TProjectOptionsForm = class(TForm)
Panel1: TPanel;
Memo1: TMemo;
ValueListEditor1: TValueListEditor;
btnGetOptions: TButton;
procedure btnGetOptionsClick(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure ValueListEditor1KeyPress(Sender: TObject; var Key: Char);
private
function GetCurrentProject: IOTAProject;
procedure GetOptionsFromIni;
procedure UpdateOptionValue;
public
Services: IOTAServices;
ProjectGroup : IOTAProjectGroup;
Project: IOTAProject;
Options : IOTAProjectOptions;
ModServices: IOTAModuleServices;
Module: IOTAModule;
NotifierIndex: Integer;
Ini : TMemIniFile;
IsSetUp : Boolean;
SetUpCount : Integer;
procedure GetProjectOptions;
procedure SetUp;
end;
var
ProjectOptionsForm: TProjectOptionsForm;
procedure Register;
implementation
{$R *.dfm}
type
TIdeNotifier = class(TNotifierObject, IOTANotifier, IOTAIDENotifier)
protected
procedure AfterCompile(Succeeded: Boolean);
procedure BeforeCompile(const Project: IOTAProject; var Cancel: Boolean);
procedure FileNotification(NotifyCode: TOTAFileNotification;
const FileName: string; var Cancel: Boolean);
end;
procedure Register;
begin
ProjectOptionsForm:= TProjectOptionsForm.Create(Nil);
ProjectOptionsForm.Services := BorlandIDEServices as IOTAServices;
ProjectOptionsForm.NotifierIndex := ProjectOptionsForm.Services.AddNotifier(TIdeNotifier.Create);
end;
procedure CloseDown;
begin
ProjectOptionsForm.Services.RemoveNotifier(ProjectOptionsForm.NotifierIndex);
ProjectOptionsForm.Close;
ProjectOptionsForm.Free;
end;
procedure TIdeNotifier.AfterCompile(Succeeded: Boolean);
begin
end;
procedure TIdeNotifier.BeforeCompile(const Project: IOTAProject; var Cancel: Boolean);
begin
end;
procedure TIdeNotifier.FileNotification(NotifyCode: TOTAFileNotification;
const FileName: string; var Cancel: Boolean);
begin
if NotifyCode in [ofnProjectDesktopLoad, ofnActiveProjectChanged] then begin
ProjectOptionsForm.Show;
// ProjectOptionsForm.Memo1.Lines.Add('Got notification');
ProjectOptionsForm.SetUp;
// ProjectOptionsForm.Memo1.Lines.Add('after GetProjectOptions');
end;
end;
procedure TProjectOptionsForm.btnGetOptionsClick(Sender: TObject);
var
KeyName,
Value,
S : String;
V : Variant;
i : Integer;
begin
GetProjectOptions;
ValueListEditor1.Strings.Clear;
for i := Low(Options.GetOptionNames) to High(Options.GetOptionNames) do begin
try
KeyName := Options.GetOptionNames[i].Name;
if CompareText(KeyName, 'HeapSize') = 0 then
NoOp;
V := Options.Values[KeyName];
if not VarIsEmpty(V) then
Value := VarToStr(V)
else
Value := '';
ValueListEditor1.InsertRow(KeyName, Value, True);
except
// Reading some CPP-related settings cause exceptions
S := '***Error ' + KeyName; // + ': ' + IntToStr(Options.Values[KeyName].Kind);
Memo1.Lines.Add(S);
end;
end;
end;
procedure TProjectOptionsForm.FormDestroy(Sender: TObject);
begin
Ini.Free;
end;
procedure TProjectOptionsForm.GetOptionsFromIni;
var
i : Integer;
KeyName : String;
TL : TStringList;
begin
ValueListEditor1.Strings.Clear;
TL := TStringList.Create;
try
Ini.ReadSection('Settings', TL);
Assert(TL.Count > 0);
for i := 0 to TL.Count - 1 do begin
KeyName := TL[i];
ValueListEditor1.InsertRow(KeyName, Ini.ReadString('Settings', KeyName, ''), True);
end;
finally
TL.Free;
end;
end;
procedure TProjectOptionsForm.FormCreate(Sender: TObject);
var
IniFileName : String;
begin
IniFileName := 'd:\aaad7\ota\ProjectOptions.Ini'; // <beware of hard-code path
Ini := TMemIniFile.Create(IniFileName);
GetOptionsFromIni;
end;
function TProjectOptionsForm.GetCurrentProject: IOTAProject;
var
i: Integer;
begin
Result := nil;
ModServices := BorlandIDEServices as IOTAModuleServices;
for i := 0 to ModServices.ModuleCount - 1 do
begin
Module := ModServices.Modules[i];
if Supports(Module, IOTAProjectGroup, ProjectGroup) then begin
Result := ProjectGroup.ActiveProject;
Options := Result.ProjectOptions;
Exit;
end
else if Supports(Module, IOTAProject, Project) then
begin // In the case of unbound packages, return the 1st
if Result = nil then begin
Result := Project;
Options := Result.ProjectOptions;
end;
end;
end;
end;
procedure TProjectOptionsForm.GetProjectOptions;
begin
Assert(Project <> Nil, 'Project');
Options := Project.ProjectOptions;
end;
procedure TProjectOptionsForm.SetUp;
begin
Project := GetCurrentProject;
GetProjectOptions;
Inc(SetUpCount);
Caption := 'Setup done ' + IntToStr(SetUpCount);
IsSetUp := True;
end;
procedure TProjectOptionsForm.UpdateOptionValue;
var
Rect : TGridRect;
S : String;
KeyName,
Value : String;
Row,
Col : Integer;
begin
if Options = Nil then
Exit;
Rect := ValueListEditor1.Selection;
// S := 'left: %d top: %d right: %d, bottom: %d';
// S := Format(S, [Rect.Left, Rect.Top, Rect.Right, Rect.Bottom]);
// Memo1.Lines.Add(S);
Row := Rect.Bottom;
Col := Rect.Left - 1;
KeyName := ValueListEditor1.Cells[Col, Row];
Value := ValueListEditor1.Values[KeyName];
Options.SetOptionValue(KeyName, Value);
Options.ModifiedState := True;
Module.Save(False, False);
end;
procedure TProjectOptionsForm.ValueListEditor1KeyPress(Sender: TObject; var
Key: Char);
begin
if Key = #13 then
UpdateOptionValue;
end;
initialization
finalization
CloseDown;
end.
How this can be done in Delphi XE7?
It cannot. This functionality was removed I'm not sure exactly when, but it has not been present for some considerable time.
What you can do is:
Create a new project.
Change its settings however you please.
Save this modified project template to some central location.
Whenever you make a new project, do so by copying this project template.
You can integrate this process into the IDE by saving your modified project template into the Object Repository. Add a project to the repository with Project | Add to Repository.

Delphi 2007: save only the breakpoint options in the DSK file?

Is it possible in Delphi to just save the breakpointss in the .DSK file for a project and no other Desktop settings?
Most of the .DSK gets in the way, but not being able to save debug breakpoints is a real pain (especially when they are conditionally or actions are attached).
I've never come across an IDE facility to save only the breakpoint-related settings in the .Dsk file.
For amusement, I thought I'd try and implement something via an IDE add-in using OTA notifications. The code below runs fine installed into a package installed in D7, and the IDE seems quite happy to re-open a project whose .Dsk file has been processed by it (and the breakpoints get set!).
As you can see, it catches an OTA notifier's FileNotification event when called with a NotifyCode of ofnProjectDesktopSave, which happens just after the IDE has saved the .Dsk file (initially with the extension '.$$$', which I faile to notice when first writing this). It then reads the saved file file, and and prepares an updated version from which all except a specified list of sections are removed. The user then has the option to save the thinned-out file back to disk. I've used a TMemIniFile to do most of the processing simply to minimize the amount of code needed.
I had zero experience of writing an OTA notifier when I read your q, but the GE Experts FAQ referenced below was immensely helpful, esp the example notifier code.
Normally, deleting a project's .Dsk file is harmless, but use this code with caution as it has not been stress-tested.
Update: I noticed that the filename received by TIdeNotifier.FileNotification event actually has an extension of '.$$$'. I'm not quite sure why that should be, but seemingly the event is called before the file is renamed to xxx.Dsk. I thought that would require a change to how
to save the thinned-out version, but evidently not.
Update#2: Having used a folder-monitoring utility to see what actually happens, it turns out that the desktop-save notification the code receives is only the first of a number of operations related to the .Dsk file. These include renaming any existing version of the .Dsk file as a .~Dsk file and finally saving the .$$$ file as the new .Dsk file.
unit DskFilesu;
interface
{$define ForDPK} // undefine to test in regular app
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Buttons, StdCtrls, IniFiles, TypInfo
{$ifdef ForDPK}
, ToolsApi
{$endif}
;
{$ifdef ForDPK}
{
Code for OTA TIdeNotifier adapted from, and courtesy of, the link on http://www.gexperts.org/open-tools-api-faq/#idenotifier
}
type
TIdeNotifier = class(TNotifierObject, IOTANotifier, IOTAIDENotifier)
protected
procedure AfterCompile(Succeeded: Boolean);
procedure BeforeCompile(const Project: IOTAProject; var Cancel: Boolean);
procedure FileNotification(NotifyCode: TOTAFileNotification;
const FileName: string; var Cancel: Boolean);
end;
{$endif}
type
TDskForm = class(TForm)
edDskFileName: TEdit;
SpeedButton1: TSpeedButton;
OpenDialog1: TOpenDialog;
lbSectionsToKeep: TListBox;
lbDskSections: TListBox;
moDskFile: TMemo;
btnSave: TButton;
procedure btnSaveClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure SpeedButton1Click(Sender: TObject);
private
procedure GetSectionsToKeep;
function GetDskFileName: String;
procedure SetDskFileName(const Value: String);
function GetDskFile: Boolean;
protected
public
DskIni : TMemIniFile;
property DskFileName : String read GetDskFileName write SetDskFileName;
end;
var
NotifierIndex: Integer;
DskForm: TDskForm;
{$ifdef ForDPK}
procedure Register;
{$endif}
implementation
{$R *.DFM}
{$ifdef ForDPK}
procedure Register;
var
Services: IOTAServices;
begin
Services := BorlandIDEServices as IOTAServices;
Assert(Assigned(Services), 'IOTAServices not available');
NotifierIndex := Services.AddNotifier(TIdeNotifier.Create);
end;
{$endif}
procedure DskPopUp(FileName : String);
var
F : TDskForm;
begin
F := TDskForm.Create(Application);
try
F.DskFileName := FileName;
F.ShowModal;
finally
F.Free;
end;
end;
function TDskForm.GetDskFileName: String;
begin
Result := edDskFileName.Text;
end;
procedure TDskForm.SetDskFileName(const Value: String);
begin
edDskFileName.Text := Value;
if Assigned(DskIni) then
FreeAndNil(DskIni);
btnSave.Enabled := False;
DskIni := TMemIniFile.Create(DskFileName);
DskIni.ReadSections(lbDskSections.Items);
GetSectionsToKeep;
end;
procedure TDskForm.btnSaveClick(Sender: TObject);
begin
DskIni.UpdateFile;
end;
procedure TDskForm.FormCreate(Sender: TObject);
begin
lbSectionsToKeep.Items.Add('watches');
lbSectionsToKeep.Items.Add('breakpoints');
lbSectionsToKeep.Items.Add('addressbreakpoints');
if not IsLibrary then
DskFileName := ChangeFileExt(Application.ExeName, '.Dsk');
end;
procedure TDskForm.GetSectionsToKeep;
var
i,
Index : Integer;
SectionName : String;
begin
moDskFile.Lines.Clear;
for i := lbDskSections.Items.Count - 1 downto 0 do begin
SectionName := lbDskSections.Items[i];
Index := lbSectionsToKeep.Items.IndexOf(SectionName);
if Index < 0 then
DskIni.EraseSection(SectionName);
end;
DskIni.GetStrings(moDskFile.Lines);
btnSave.Enabled := True;
end;
function TDskForm.GetDskFile: Boolean;
begin
OpenDialog1.FileName := DskFileName;
Result := OpenDialog1.Execute;
if Result then
DskFileName := OpenDialog1.FileName;
end;
procedure TDskForm.SpeedButton1Click(Sender: TObject);
begin
GetDskFile;
end;
{$ifdef ForDPK}
procedure RemoveNotifier;
var
Services: IOTAServices;
begin
if NotifierIndex <> -1 then
begin
Services := BorlandIDEServices as IOTAServices;
Assert(Assigned(Services), 'IOTAServices not available');
Services.RemoveNotifier(NotifierIndex);
end;
end;
function MsgServices: IOTAMessageServices;
begin
Result := (BorlandIDEServices as IOTAMessageServices);
Assert(Result <> nil, 'IOTAMessageServices not available');
end;
procedure TIdeNotifier.AfterCompile(Succeeded: Boolean);
begin
end;
procedure TIdeNotifier.BeforeCompile(const Project: IOTAProject; var Cancel: Boolean);
begin
Cancel := False;
end;
procedure TIdeNotifier.FileNotification(NotifyCode: TOTAFileNotification;
const FileName: string; var Cancel: Boolean);
begin
Cancel := False;
// Note: The FileName passed below has an extension of '.$$$'
if NotifyCode = ofnProjectDesktopSave then
DskPopup(FileName);
end;
initialization
finalization
RemoveNotifier;
{$endif}
end.

IdHttpServer form caption not updating

I know i have posted a similar question before but i am not able to get it working I have this simple code :
procedure TfrmMain.srvrConnect(AContext: TIdContext); //idhttpserver on connect event
var
S,C : String;
begin
repeat
s := s + AContext.Connection.Socket.ReadChar;
until AContext.Connection.Socket.InputBufferIsEmpty = True;
frmMain.caption := S;
Memo1.Lines.Add(S);
end;
The strings displays ok in the memo but the caption doesn't get updated
TIdHTTPServer is a multi-threaded component. TIdContext runs in its own worker thread. You cannot safely update the Form's Caption (or do anything else with the UI) from outside of the main thread. You need to synchronize with the main thread, such as with the TIdSync or TIdNotify class.
On a side note, calling ReadChar() in a loop is very inefficient, not to mention error-prone if you are using Delphi 2009+ since it cannot return data for surrogate pairs.
Use something more like this instead;
type
TDataNotify = class(TIdNotify)
protected
Data: String;
procedure DoNotify; override;
public
constructor Create(const S: String);
class procedure DataAvailable(const S: String);
end;
constructor TDataNotify.Create(const S: String);
begin
inherited Create;
Data := S;
end;
procedure TDataNotify.DoNotify;
begin
frmMain.Caption := Data;
frmMain.Memo1.Lines.Add(Data);
end;
class procedure TDataNotify.DataAvailable(const S: String);
begin
Create(S).Notify;
end;
procedure TfrmMain.srvrConnect(AContext: TIdContext); //idhttpserver on connect event
var
S: String;
begin
AContext.Connection.IOHandler.CheckForDataOnSource(IdTimeoutDefault);
if not AContext.Connection.IOHandler.InputBufferIsEmpty then
begin
S := AContext.Connection.IOHandler.InputBufferAsString;
TDataNotify.DataAvailable(S);
end;
end;
First, make sure you are writing to the right variable. Are you sure that frmMain is the form you want the caption do change?
Also, you could try:
procedure TfrmMain.srvrConnect(AContext: TIdContext); //idhttpserver on connect event
var
S,C : String;
begin
repeat
s := s + AContext.Connection.Socket.ReadChar;
until AContext.Connection.Socket.InputBufferIsEmpty = True;
oCaption := S;
TThread.Synchronize(nil, Self.ChangeCaption);
end;
procedure TfrmMain.ChangeCaption;
begin
Self.Caption := oCaption;
Memo1.Lines.Add(oCaption);
end;
And finally, make sure that the first line on S is not a blank line, because the form's caption will not show strings that contains a line feed.

Resources