I have a Windows service written in Delphi. One of the third-party resources it uses occasionally gets corrupted, and the only way I've found to fix the situation is to exit and restart the program. I can detect when the resource is corrupted from within the program, and I can tell Windows to restart the service after it stops, but I can't figure out how to have the service tell itself to stop.
The program is pretty simple. I created a service application in what seems to be the normal way. I have a subclass of TService to manage the service, while all of the functionality occurs in a separate thread. The TService subclass pretty much just manages the execution of the subthread, and it's in the subthread that I would be detecting the corruption.
For reference, here's the header info for the service and subthread.
type
TScannerThread = class(TThread)
private
Scanner : TScanner;
DefaultDir : String;
ImageDir : String;
procedure CheckScanner;
public
Parent : TComponent;
procedure Execute; override;
end;
TCardScanSvc = class(TService)
procedure ServiceCreate(Sender: TObject);
procedure ServiceExecute(Sender: TService);
procedure ServiceStart(Sender: TService; var Started: Boolean);
procedure ServiceStop(Sender: TService; var Stopped: Boolean);
procedure ServicePause(Sender: TService; var Paused: Boolean);
procedure ServiceContinue(Sender: TService; var Continued: Boolean);
private
ScannerThread : TScannerThread;
public
function GetServiceController: TServiceController; override;
end;
var
CardScanSvc : TCardScanSvc;
In a GUI application, I'd call Application.Terminate, but TServiceApplication doesn't seem to have that method. I can terminate the subthread, but the main thread never notices, and Windows thinks the service is still running. I can't really think of much else to try.
The program was originally created in Delphi 5, and I'm currently using Delphi 2007, in case that makes a difference.
Edit:
With mghie's code, I can stop the service, but Windows will only restart the service if it fails unexpectedly, not if it's stopped normally. What I'm going to do is make a separate service application, have the first signal the second if it has problems, and then have the second restart the first.
There is no problem having the service stop itself - I just tried with one of my own services, written with Delphi 4 (without using the TService class). The following routine works for me:
procedure TTestService.StopService;
var
Scm, Svc: SC_Handle;
Status: SERVICE_STATUS;
begin
Scm := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
if Scm <> 0 then begin
Svc := OpenService(Scm, PChar(ServiceName), SERVICE_ALL_ACCESS);
if Svc <> 0 then begin
ControlService(Svc, SERVICE_CONTROL_STOP, Status);
// handle Status....
CloseServiceHandle(Svc);
end;
CloseServiceHandle(Scm);
end;
end;
You need to check whether it will also work from your worker thread.
You should be able to use WMI (Windows Management Instrumentation) to restart a service, even from within the service itself. Don't know if this would cause any strange problems but it should work. Here's an article on doing WMI with Delphi.
UPDATE: Well well, I assumed (my mistake) that there is a single WMI service restart command, such as the button you can click in the services maangement listing. Apparently not.
You could instead write a console app that the service starts when the data is corrupted. The console app would restart the service from a separate process.
I have found a simpler alternative that should work. You can add a method to your TService subclass:
procedure TSomeService.StopService;
begin
Controller(SERVICE_CONTROL_STOP);
end;
I am using the same setup as the OP - specifically, a TService descendant that simply starts a worker thread and then does nothing but process Windows messages. Unfortunately, you cannot call Controller from the worker thread because it is protected. Of course the simple way around it is to create a public method as I showed above. To use this from the worker thread you will need a reference to the TService object accessible from within the worker thread. I do this by passing my TService object into my worker thread in the thread's constructor.
Related
working with a Windows Service application in Delphi, I stumbled on the issue as in the subject.
I do start a default Delphi Windows Service project on the IDE, follow the wizard and in the end I have a project and a
TService unit. I add to this project another unit, a Data Module (named DM) in which the service code logic is contained.
The DM has a TTimer (design-time) that runs a relatively long job.
Case 1:
DM is created by default in design-time. I have the following code in my TService Start/Stop
procedure TOmegaCAOraNT.ServiceStart(Sender: TService;
var Started: Boolean);
begin
DM.Timer1.Enabled := True;
Started := true;
end;
procedure TOmegaCAOraNT.ServiceStop(Sender: TService; var Stopped: Boolean);
begin
DM.Agent_Stop;
Stopped := true;
end;
When I try to Stop the Service via Windows SCM - in appearance it confirms the Stop, field Status becomes empty - but it does not.
I can see the service .exe still running for a while, and what's more it does terminate the Timer's long job in the middle,
doing part of it only!
This is an undesired behavior!
I fixed this in the second case
Case 2:
DM is created in run-time. The Timer is enabled on DM.OnCreate
I have the following code in my TService Start/Stop
procedure TOmegaCAOraNT.ServiceStart(Sender: TService; var Started: Boolean);
begin
FDataModule := TDM.Create(nil);
Started := true;
end;
procedure TOmegaCAOraNT.ServiceStop(Sender: TService; var Stopped: Boolean);
begin
FreeAndNil(FDataModule);
Stopped := true;
end;
When I try to Stop the Service via Windows SCM - it throws the following Warning:
"Windows could not stop the SERVICE> service on the Local Computer.
The service did not return an error. his could be an internal Windows error or an internal service error.
if the error persists, contact your system Administrator"
field Status remains Started. Timer' long job finishes until the end, and then the service really stops (refresh in SCM to see, Status empty)
This is desired behavior !
My problem is that I would like the DM to be created in design-time, and not in run-time
My question is:
can I have the right behavior of run-time DM (Case 2), with a design-time DM (Case 1) ?
thanks and best regards,
Altin
TService runs in is own worker thread at run-time.
If you configure the DM to be auto-created, it (and its TTimer) will be created in the main thread at run-time, not in the service thread. And thus, the TTimer will run in the main thread, and can be activated only by the main thread, not in the TService.OnStart event handler (an EOutOfResources exception will be raised if you try).
If you manually create the DM in the TService.OnStart event handler, it (and its TTimer) will be created in the service thread, not in the main thread. The TTimer will run in the service thread, and can be (de)activated in the TService events.
Either way, make sure your TTimer.OnTimer event handler uses thread-safe code.
Also, the TService.OnStop event handler must call the TService.ReportStatus() method periodically (before the TService.WaitHint interval elapses) while waiting for other threads to stop whatever they are doing. Which means you shouldn't use thread-blocking code in the TService.OnStop event handler.
You are not handling this correctly, which is why the SCM is having problems.
We have a service (written in C#) running to check somethings every 10 minutes and if something new happened, then send an email to someone special.
We also have other Delphi program and want to pass a parameter to the service to act on and send email immediately (I mean regardless than 10 minutes interval).
How to do that while service is running ?
note: There is no way to migrate to C# we have to do that in Delphi.
There's also a possibility to use ControlService API to send the service a user-defined control code. (The service has to be written to respond to that specific control code.)
You need to use some form of inter process communication (IPC). There are many possibilities. Most commonly used for such a scenario are named pipes and TCP/sockets.
There are some good answers here already... and here's mine:
You could use a text file or the windows registry to flag for action. This way your Delphi service can react upon start-up should the trigger have occured while your service was not running. Any information/parameters you wish to convey can be included in the registry-key value or as file data.
Win Registry Method:
If you use a registry-key make sure that both apps can read and write to the same key.
In your Delphi Service implement the RegNotifyChangeKeyValue WinAPI which will notify when the key is added/altered. Here's an idea how you can implement the listner in Delphi: Monitoring Registry Changes
File Method:
To be notified about file changes you do not need to poll for changes. Below is code for a solution based on the FindFirstChangeNotification WinAPI. Your Delphi Service can implement the TFileWatch class. You will also need a unit with the class TDirectoryWatch class by Angus Johnson.
unit FileWatch;
interface
uses Classes,
SysUtils,
DirWatch; //by Angus Johnson: http://www.angusj.com/delphi/dirwatch.html
type TFileNotifyEventType = (feCreated, feModified, feDeleted);
TFileNotifyEvent = procedure(Sender: TObject; FileEventType : TFileNotifyEventType) of object;
TFileWatch = class(TComponent)
private
FDirWatch : TDirectoryWatch;
FFileToWatch : string;
FFileAge : integer; //if -1 then file does not exist
FFileExists : boolean;
procedure OnFolderChangeEvent(Sender: TObject);
protected
public
OnFileNotifyEvent : TFileNotifyEvent;
property Filename : string read FFileToWatch;
constructor Create(aOwner: TComponent; FileToWatch : string);
destructor Destroy();
end;
implementation
{ TFileWatch }
constructor TFileWatch.Create(aOwner: TComponent; FileToWatch: string);
begin
inherited Create(aOwner);
FDirWatch := TDirectoryWatch.Create(Self);
FDirWatch.Directory := ExtractFilePath(FileToWatch);
FDirWatch.OnChange := OnFolderChangeEvent;
FDirWatch.NotifyFilters := [nfFilename, nfLastWrite];
FDirWatch.Active := true;
FFileToWatch := FileToWatch;
FFileAge := FileAge(FFileToWatch);
FFileExists := FFileAge > -1;
end;
destructor TFileWatch.Destroy;
begin
FDirWatch.Free;
inherited Destroy;
end;
procedure TFileWatch.OnFolderChangeEvent(Sender: TObject);
var MyFileAge : integer;
MyFileExists : boolean;
FileEventType : TFileNotifyEventType;
begin
//Check to see if the event has been fired by our file in question
MyFileAge := FileAge(FFileToWatch);
if MyFileAge = FFileAge then
exit; //Nothing has happened, exit.
//Figure out if the file has been created, modified or deleted
MyFileExists := MyFileAge > -1;
if MyFileExists and not FFileExists then
FileEventType := feCreated
else if not MyFileExists and FFileExists then
FileEventType := feDeleted
else
FileEventType := feModified;
FFileAge := MyFileAge;
FFileExists := MyFileExists;
if Assigned(OnFileNotifyEvent) then
OnFileNotifyEvent(Self, FileEventType);
end;
end.
I often communicate via a database. I'd store a certain value with process X, and process Y reads it.
The nice thing about that design is that the two applications don't need to know eachother. They can easily run on different machines, and you can have multiple readers and writers, so you can easily scale things up. You also get encryption and compressed connections for free if you need it, and all sorts of complicated multi user stuff is taken care of.
I would suggest adding a WCF Service to (hosted by) your Windows service exposing the required function.
I am handling from my Application associated extension files from Windows. So when you double click a file from Windows it will execute my program, and I handle the file from there, something like:
procedure TMainForm.FormCreate(Sender: TObject);
var
i: Integer;
begin
for i := 0 to ParamCount -1 do
begin
if SameText(ExtractFileExt(ParamStr(i)), '.ext1') then
begin
// handle my file..
// break if needed
end else
if SameText(ExtractFileExt(ParamStr(i)), '.ext2') then
begin
// handle my file..
// break if needed
end else
end;
end;
That works pretty much how I want it to, but when I was testing I realised it does not consider using only one instance of my program.
So for example, if I selected several Files from Windows and opened them all at the same time, this will create the same number of instances of my program with the number of Files being opened.
What would be a good way to approach this, so that instead of several instances of my program being opened, any additional Files from Windows being opened will simply focus back to the one and only instance, and I handle the Files as normal?
Thanks
UPDATE
I found a good article here: http://www.delphidabbler.com/articles?article=13&part=2 which I think is what I need, and shows how to work with the Windows API as mentioned by rhooligan. I am going to read through it now..
Here is some simple example code that gets the job done. I hope it is self-explanatory.
program StartupProject;
uses
SysUtils,
Messages,
Windows,
Forms,
uMainForm in 'uMainForm.pas' {MainForm};
{$R *.res}
procedure Main;
var
i: Integer;
Arg: string;
Window: HWND;
CopyDataStruct: TCopyDataStruct;
begin
Window := FindWindow(SWindowClassName, nil);
if Window=0 then begin
Application.Initialize;
Application.MainFormOnTaskbar := True;
Application.CreateForm(TMainForm, MainForm);
Application.Run;
end else begin
FillChar(CopyDataStruct, Sizeof(CopyDataStruct), 0);
for i := 1 to ParamCount do begin
Arg := ParamStr(i);
CopyDataStruct.cbData := (Length(Arg)+1)*SizeOf(Char);
CopyDataStruct.lpData := PChar(Arg);
SendMessage(Window, WM_COPYDATA, 0, NativeInt(#CopyDataStruct));
end;
SetForegroundWindow(Window);
end;
end;
begin
Main;
end.
unit uMainForm;
interface
uses
Windows, Messages, SysUtils, Classes, Controls, Forms, StdCtrls;
type
TMainForm = class(TForm)
ListBox1: TListBox;
procedure FormCreate(Sender: TObject);
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure WMCopyData(var Message: TWMCopyData); message WM_COPYDATA;
public
procedure ProcessArgument(const Arg: string);
end;
var
MainForm: TMainForm;
const
SWindowClassName = 'VeryUniqueNameToAvoidUnexpectedCollisions';
implementation
{$R *.dfm}
{ TMainForm }
procedure TMainForm.CreateParams(var Params: TCreateParams);
begin
inherited;
Params.WinClassName := SWindowClassName;
end;
procedure TMainForm.FormCreate(Sender: TObject);
var
i: Integer;
begin
for i := 1 to ParamCount do begin
ProcessArgument(ParamStr(i));
end;
end;
procedure TMainForm.ProcessArgument(const Arg: string);
begin
ListBox1.Items.Add(Arg);
end;
procedure TMainForm.WMCopyData(var Message: TWMCopyData);
var
Arg: string;
begin
SetString(Arg, PChar(Message.CopyDataStruct.lpData), (Message.CopyDataStruct.cbData div SizeOf(Char))-1);
ProcessArgument(Arg);
Application.Restore;
Application.BringToFront;
end;
end.
The logic goes something like this. When you start your application, you iterate through the list of running processes and see if your application is already running. If it is running, you need to activate the window of that instance and then exit.
Everything you need to do this is in the Windows API. I found this sample code on CodeProject.com that deals with processes:
http://www.codeproject.com/KB/system/Win32Process.aspx
On finding and activating a window, the basic approach is to find the window of interest using the window class name then activate it.
http://www.vb6.us/tutorials/activate-window-api
Hopefully this gives you a good starting point.
There are many answers here that show how to implement this. I want to show why NOT to use the FindWindow approach.
I am using FindWindow (something similar with the one shown by David H) and I have seen it failed starting with Win10 - I don't know what they changed in Win10.
I think the gap between the time when the app starts and the time when we set the unique ID via CreateParams is too big so another instance has somehow time to run in this gap/interval.
Imagine two instances started at only 1ms distance (let's say that the user click the EXE file and then presses enter and keeps it pressed by accident for a short while). Both instances will check to see if a window with that unique ID exists, but none of them had the chance to set the flag/unique ID because creating the form is slow and the unique ID is set only when the form is constructed. So, both instances will run.
So, I would recommend the CreateSemaphore solution instead:
https://stackoverflow.com/a/460480/46207
Marjan V already proposed this solution but didn't explained why it is better/safer.
I'd use mutexes. You create one when your program starts.
When the creation fails it means another instance is already running. You then send this instance a message with your command line parameters and close. When your app receives a message with a command line, it can parse the parameters like you are already doing, check to see whether it already has the file(s) open and proceed accordingly.
Processing this app specific message ia also the place to get your app to the front if it isn't already. Please do this politely (SetForegroundWindow) without trying to force your app in front of all others.
function CreateMutexes(const MutexName: String): boolean;
// Creates the two mutexes to see if the program is already running.
// One of the mutexes is created in the global name space (which makes it
// possible to access the mutex across user sessions in Windows XP); the other
// is created in the session name space (because versions of Windows NT prior
// to 4.0 TSE don't have a global name space and don't support the 'Global\'
// prefix).
var
SecurityDesc: TSecurityDescriptor;
SecurityAttr: TSecurityAttributes;
begin
// By default on Windows NT, created mutexes are accessible only by the user
// running the process. We need our mutexes to be accessible to all users, so
// that the mutex detection can work across user sessions in Windows XP. To
// do this we use a security descriptor with a null DACL.
InitializeSecurityDescriptor(#SecurityDesc, SECURITY_DESCRIPTOR_REVISION);
SetSecurityDescriptorDacl(#SecurityDesc, True, nil, False);
SecurityAttr.nLength := SizeOf(SecurityAttr);
SecurityAttr.lpSecurityDescriptor := #SecurityDesc;
SecurityAttr.bInheritHandle := False;
if (CreateMutex(#SecurityAttr, False, PChar(MutexName)) <> 0 )
and (CreateMutex(#SecurityAttr, False, PChar('Global\' + MutexName)) <> 0 ) then
Result := True
else
Result := False;
end;
initialization
if not CreateMutexes('MyAppNameIsRunningMutex') then
//Find and SendMessage to running instance
;
end.
Note: above code is adapted from an example on the InnoSetup site. InnoSetup creates installer applications and uses this approach in the installer to check whether (a previous version of) the application being installed is already running.
Finding the other instance and sending it a message, I'll leave for another question (or you can use the WM_COPYDATA approach from David's answer). Actually, there is a StackOverflow question that deals exactly with this: How to get the process thread that owns a mutex Getting the process/thread that owns the mutex may be a bit of a challenge, but the answers to this question do address ways to get the information from one instance to the other.
Windows has different ways to handle file associations to executable.
The "command line" approach is only the simplest one, but also the most limited one.
It also supports DDE (it still works although officially deprecated) and COM (see http://msdn.microsoft.com/en-us/library/windows/desktop/cc144171(v=vs.85).aspx).
If I recall correctly both DDE and COM will let your application receive the whole list of selected files.
I used window/message approach by myself with addition of events for tracking if the other instance is running:
Try to create event "Global\MyAppCode" (the "Global" namespace is used for handling various user sessions as I needed single instance system-wide; in your case you'll probably prefer "Local" namespace which is set by default)
If CreateEvent returned error and GetLastError = ERROR_ALREADY_EXISTS then the instance is running already.
FindWindow/WM_COPYDATA to transfer data to that instance.
But the drawbacks with messages/windows are more than significant:
You must always keep your window's Caption constant. Otherwise you'll have to list all the windows in the system and loop through them for partial occurrence of some constant part. Moreover the window's caption could be easily changed by a user or 3rd part app so the search would fail.
Method requires a window to be created so no console/service apps, or they must create a window and perform message loop especially for handling the single instance.
I'm not sure FindWindow could find a window that is opened in another user session
For me, WM_COPYDATA is rather awkward method.
So currently I'm a fan of named pipe approach (haven't implemented it yet though).
On launch, app tries to connect to "Global\MyAppPipe". If successed, other instance is running. If failed, it creates this pipe and finishes instance check.
2nd instance writes the required data to pipe and exits.
1st instance receives data and does some stuff.
It works through all user sessions (with namespace "Global") or just a current session; it doesn't depend on strings used by UI (no localization and modification issues); it works with console and service apps (you'll need to implement pipe reading in a separate thread/message loop though).
I poll a lot of devices in network (more than 300) by iterative ping.
The program polls the devices sequentially, so it's slow.
I'd like to enhance the speed of polling.
There some ways to do this in Delphi 7:
Each device has a thread doing ping. Manage threads manually.
Learn and use Indy 10. Need examples.
Use overlapped I/O based on window messages.
Use completion ports based on events.
What is faster, easier? Please, provide some examples or links for example.
Flooding the network with ICMP is not a good idea.
You might want to consider some kind of thread pool and queue up the ping requests and have a fixed number of threads doing the requests.
Personally I would go with IOCP. I'm using that very successfully for the transport implementation in NexusDB.
If you want to perform 300 send/receive cycles using blocking sockets and threads in parallel, you end up needing 300 threads.
With IOCP, after you've associated the sockets with the IOCP, you can perform the 300 send operations, and they will return instantly before the operation is completed. As the operations are completed, so called completion packages will be queued to the IOCP. You then have a pool of threads waiting on the IOCP, and the OS wakes them up as the completion packets come in. In reaction to completed send operations you can then perform the receive operations. The receive operations also return instantly and once actually completed get queued to the IOCP.
The real special thing about an IOCP is that it knows which threads belong to it and are currently processing completion packages. And the IOCP only wakes up new threads if the total number of active threads (not in a kernel mode wait state) is lower than the concurrency number of the IOCP (by default that equals the number of logical cores available on the machine). Also, if there are threads waiting for completion packages on the IOCP (which haven't been started yet despite completion packages being queued because the number of active threads was equal to the concurrancy number), the moment one of the threads that is currently processing a completion package enters a kernel mode wait state for any reason, one of the waiting threads is started.
Threads returning to the IOCP pick up completion packages in LIFO order. That is, if a thread is returning to the IOCP and there are completion packages still waiting, that thread directly picks up the next completion package, instead of being put into a wait state and the thread waiting for the longest time waking up.
Under optimal conditions, you will have a number of threads equal to the number of available cores running concurrently (one on each core), picking up the next completion package, processing it, returning to the IOCP and directly picking up the next completion package, all without ever entering a kernel mode wait state or a thread context switch having to take place.
If you would have 300 threads and blocking operations instead, not only would you waste at least 300 MB address space (for the reserved space for the stacks), but you would also have constant thread context switches as one thread enters a wait state (waiting for a send or receive to complete) and the next thread with a completed send or receive waking up. – Thorsten Engler 12 hours ago
Direct ICMP access is deprecated on windows. Direct access to the ICMP protocol on Windows is controlled. Due to malicious use of ICMP/ping/traceroute style raw sockets, I believe that on some versions of Windows you will need to use Windows own api. Windows XP, Vista, and Windows 7, in particular, don't let user programs access raw sockets.
I have used the canned-functionality in ICMP.dll, which is what some Delphi ping components do, but a comment below alerted me to the fact that this is considered "using an undocumented API interface".
Here's a sample of the main delphi ping component call itself:
function TICMP.ping: pIcmpEchoReply;
{var }
begin
// Get/Set address to ping
if ResolveAddress = True then begin
// Send packet and block till timeout or response
_NPkts := _IcmpSendEcho(_hICMP, _Address,
_pEchoRequestData, _EchoRequestSize,
#_IPOptions,
_pIPEchoReply, _EchoReplySize,
_TimeOut);
if _NPkts = 0 then begin
result := nil;
status := CICMP_NO_RESPONSE;
end else begin
result := _pIPEchoReply;
end;
end else begin
status := CICMP_RESOLVE_ERROR;
result := nil;
end;
end;
I believe that most modern Ping component implementations are going to be based on a similar bit of code to the one above, and I have used it to run this ping operation in a background thread, without any probems. (Demo program included in link below).
Full sample source code for the ICMP.DLL based demo is here.
UPDATE A more modern IPHLPAPI.DLL sample is found at About.com here.
Here's an article from Delphi3000 showing how to use IOCP to create a thread pool. I am not the author of this code, but the author's information is in the source code.
I'm re-posting the comments and code here:
Everyone by now should understand what
a thread is, the principles of threads
and so on. For those in need, the
simple function of a thread is to
separate processing from one thread to
another, to allow concurrent and
parallel execution. The main principle
of threads is just as simple, memory
allocated which is referenced between
threads must be marshalled to ensure
safety of access. There are a number
of other principles but this is really
the one to care about.
And on..
A thread safe queue will allow
multiple threads to add and remove,
push and pop values to and from the
queue safely on a First on First off
basis. With an efficient and well
written queue you can have a highly
useful component in developing
threaded applications, from helping
with thread safe logging, to
asynchronous processing of requests.
A thread pool is simply a thread or a
number of threads which are most
commonly used to manage a queue of
requests. For example a web server
which would have a continuous queue of
requests needing to be processed use
thread pools to manage the http
requests, or a COM+ or DCOM server
uses a thread pool to handle the rpc
requests. This is done so there is
less impact from the processing of one
request to another, say if you ran 3
requests synchronously and the first
request took 1 minute to complete, the
second two requests would not complete
for at least 1 minute adding on top
there own time to process, and for
most of the clients this is not
acceptable.
So how to do this..
Starting with the queue!!
Delphi does provides a TQueue object
which is available but is
unfortunately not thread safe nor
really too efficient, but people
should look at the Contnrs.pas file to
see how borland write there stacks and
queues. There are only two main
functions required for a queue, these
are add and remove/push and pop.
Add/push will add a value, pointer or
object to the end of a queue. And
remove/pop will remove and return the
first value in the queue.
You could derive from TQueue object
and override the protected methods and
add in critical sections, this will
get you some of the way, but I would
want my queue to wait until new
requests are in the queue, and put the
thread into a state of rest while it
waits for new requests. This could be
done by adding in Mutexes or signaling
events but there is an easier way. The
windows api provides an IO completion
queue which provides us with thread
safe access to a queue, and a state of
rest while waiting for new request in
the queue.
Implementing the Thread Pool
The thread pool is going to be very
simple and will manage x number of
threads desired and pass each queue
request to an event provided to be
processed. There is rarely a need to
implement a TThread class and your
logic to be implemented and
encapsulated within the execute event
of the class, thus a simple
TSimpleThread class can be created
which will execute any method in any
object within the context of another
thread. Once people understand this,
all you need to concern yourself with
is allocated memory.
Here is how it is implemented.
TThreadQueue and TThreadPool
implementation
(* Implemented for Delphi3000.com Articles, 11/01/2004
Chris Baldwin
Director & Chief Architect
Alive Technology Limited
http://www.alivetechnology.com
*)
unit ThreadUtilities;
uses Windows, SysUtils, Classes;
type
EThreadStackFinalized = class(Exception);
TSimpleThread = class;
// Thread Safe Pointer Queue
TThreadQueue = class
private
FFinalized: Boolean;
FIOQueue: THandle;
public
constructor Create;
destructor Destroy; override;
procedure Finalize;
procedure Push(Data: Pointer);
function Pop(var Data: Pointer): Boolean;
property Finalized: Boolean read FFinalized;
end;
TThreadExecuteEvent = procedure (Thread: TThread) of object;
TSimpleThread = class(TThread)
private
FExecuteEvent: TThreadExecuteEvent;
protected
procedure Execute(); override;
public
constructor Create(CreateSuspended: Boolean; ExecuteEvent: TThreadExecuteEvent; AFreeOnTerminate: Boolean);
end;
TThreadPoolEvent = procedure (Data: Pointer; AThread: TThread) of Object;
TThreadPool = class(TObject)
private
FThreads: TList;
FThreadQueue: TThreadQueue;
FHandlePoolEvent: TThreadPoolEvent;
procedure DoHandleThreadExecute(Thread: TThread);
public
constructor Create( HandlePoolEvent: TThreadPoolEvent; MaxThreads: Integer = 1); virtual;
destructor Destroy; override;
procedure Add(const Data: Pointer);
end;
implementation
{ TThreadQueue }
constructor TThreadQueue.Create;
begin
//-- Create IO Completion Queue
FIOQueue := CreateIOCompletionPort(INVALID_HANDLE_VALUE, 0, 0, 0);
FFinalized := False;
end;
destructor TThreadQueue.Destroy;
begin
//-- Destroy Completion Queue
if (FIOQueue <> 0) then
CloseHandle(FIOQueue);
inherited;
end;
procedure TThreadQueue.Finalize;
begin
//-- Post a finialize pointer on to the queue
PostQueuedCompletionStatus(FIOQueue, 0, 0, Pointer($FFFFFFFF));
FFinalized := True;
end;
(* Pop will return false if the queue is completed *)
function TThreadQueue.Pop(var Data: Pointer): Boolean;
var
A: Cardinal;
OL: POverLapped;
begin
Result := True;
if (not FFinalized) then
//-- Remove/Pop the first pointer from the queue or wait
GetQueuedCompletionStatus(FIOQueue, A, Cardinal(Data), OL, INFINITE);
//-- Check if we have finalized the queue for completion
if FFinalized or (OL = Pointer($FFFFFFFF)) then begin
Data := nil;
Result := False;
Finalize;
end;
end;
procedure TThreadQueue.Push(Data: Pointer);
begin
if FFinalized then
Raise EThreadStackFinalized.Create('Stack is finalized');
//-- Add/Push a pointer on to the end of the queue
PostQueuedCompletionStatus(FIOQueue, 0, Cardinal(Data), nil);
end;
{ TSimpleThread }
constructor TSimpleThread.Create(CreateSuspended: Boolean;
ExecuteEvent: TThreadExecuteEvent; AFreeOnTerminate: Boolean);
begin
FreeOnTerminate := AFreeOnTerminate;
FExecuteEvent := ExecuteEvent;
inherited Create(CreateSuspended);
end;
procedure TSimpleThread.Execute;
begin
if Assigned(FExecuteEvent) then
FExecuteEvent(Self);
end;
{ TThreadPool }
procedure TThreadPool.Add(const Data: Pointer);
begin
FThreadQueue.Push(Data);
end;
constructor TThreadPool.Create(HandlePoolEvent: TThreadPoolEvent;
MaxThreads: Integer);
begin
FHandlePoolEvent := HandlePoolEvent;
FThreadQueue := TThreadQueue.Create;
FThreads := TList.Create;
while FThreads.Count < MaxThreads do
FThreads.Add(TSimpleThread.Create(False, DoHandleThreadExecute, False));
end;
destructor TThreadPool.Destroy;
var
t: Integer;
begin
FThreadQueue.Finalize;
for t := 0 to FThreads.Count-1 do
TThread(FThreads[t]).Terminate;
while (FThreads.Count > 0) do begin
TThread(FThreads[0]).WaitFor;
TThread(FThreads[0]).Free;
FThreads.Delete(0);
end;
FThreadQueue.Free;
FThreads.Free;
inherited;
end;
procedure TThreadPool.DoHandleThreadExecute(Thread: TThread);
var
Data: Pointer;
begin
while FThreadQueue.Pop(Data) and (not TSimpleThread(Thread).Terminated) do begin
try
FHandlePoolEvent(Data, Thread);
except
end;
end;
end;
end.
As you can see it's quite straight
forward, and with this you can
implement very easily any queuing of
requests over threads and really any
type of requirement that requires
threading can be done using these
object and save you a lot of time and
effort.
You can use this to queue requests
from one thread to multiple threads,
or queue requests from multiple
threads down to one thread which makes
this quite a nice solution.
Here are some examples of using these
objects.
Thread safe logging
To allow multiple
threads to asynchronously write to a
log file.
uses Windows, ThreadUtilities,...;
type
PLogRequest = ^TLogRequest;
TLogRequest = record
LogText: String;
end;
TThreadFileLog = class(TObject)
private
FFileName: String;
FThreadPool: TThreadPool;
procedure HandleLogRequest(Data: Pointer; AThread: TThread);
public
constructor Create(const FileName: string);
destructor Destroy; override;
procedure Log(const LogText: string);
end;
implementation
(* Simple reuse of a logtofile function for example *)
procedure LogToFile(const FileName, LogString: String);
var
F: TextFile;
begin
AssignFile(F, FileName);
if not FileExists(FileName) then
Rewrite(F)
else
Append(F);
try
Writeln(F, DateTimeToStr(Now) + ': ' + LogString);
finally
CloseFile(F);
end;
end;
constructor TThreadFileLog.Create(const FileName: string);
begin
FFileName := FileName;
//-- Pool of one thread to handle queue of logs
FThreadPool := TThreadPool.Create(HandleLogRequest, 1);
end;
destructor TThreadFileLog.Destroy;
begin
FThreadPool.Free;
inherited;
end;
procedure TThreadFileLog.HandleLogRequest(Data: Pointer; AThread: TThread);
var
Request: PLogRequest;
begin
Request := Data;
try
LogToFile(FFileName, Request^.LogText);
finally
Dispose(Request);
end;
end;
procedure TThreadFileLog.Log(const LogText: string);
var
Request: PLogRequest;
begin
New(Request);
Request^.LogText := LogText;
FThreadPool.Add(Request);
end;
As this is logging to a file it will
process all requests down to a single
thread, but you could do rich email
notifications with a higher thread
count, or even better, process
profiling with what’s going on or
steps in your program which I will
demonstrate in another article as this
one has got quite long now.
For now I will leave you with this,
enjoy.. Leave a comment if there's
anything people are stuck with.
Chris
Do you need a response from every machine on the network, or are these 300 machines just a subset of the larger network?
If you need a response from every machine, you could consider using a broadcast address or multicast address for your echo request.
Please give a try on "chknodes" parallel ping for Linux which will send a single ping to all nodes of your network. It will do also dns reverse lookup and request http response if specified so. It's written completely in bash i.e. you can easily check it or modify it to your needs. Here is a printout of help:
chknodes -h
chknodes ---- fast parallel ping
chknodes [-l|--log] [-h|--help] [-H|--http] [-u|--uninstall] [-v|--version] [-V|--verbose]
-l | --log Log to file
-h | --help Show this help screen
-H | --http Check also http response
-n | --names Get also host names
-u | --uninstall Remove installation
-v | --version Show version
-V | --verbose Show each ip address pinged
You need to give execute right for it (like with any sh/bash script) in order to run it:
chmod +x chknodes
On the first run i.e.
./chknodes
it will suggest to install itself to /usr/local/bin/chknodes, after that giving just
chknodes
will be enough. You can find it here:
www.homelinuxpc.com/download/chknodes
I'm running my Standalone Intraweb App as a service. Now i need to implement a function that writes
a "heartbeat" timestamp to a database table. I've done this in other service app that uses
the TService Classm where i can use Events like OnAfterInstall, OnExecute etc.
Is there a way i can use that events in a standalone intraweb app running as service ?
Thanks for all info
Wolfgang
I started doing exactly this in my own Intraweb application, though because the IWServiceWizard hides the service details including the main Execute loop, I did it all server-side, I was using Application Mode.
I defined a heartbeat method on my session class (RunSQL is a method on my own Data Access Layer object DBConnection, this could be a simple wrapper around TADOConnection).
function TIWUserSession.UpdateHeartbeat: boolean;
var
sSQL : string;
begin
sSQL := 'UPDATE Heartbeats SET LastComms = getdate()'+
' WHERE SessionID = '+ IntToStr(FSessionID);
Result := DBConnection.RunSQL(sSQL);
end;
Once I'd done this it was trivial to call this method (for example) whenever a user opened a new web page.
procedure TIWMyPage.IWAppFormCreate(Sender: TObject);
begin
inherited;
Session.UpdateHeartbeat;
end;
This can also be used whenever the user does something that communicates with the server, even if it's an asynchronous event (AJAX).
procedure TIWMyPage.btnRefreshAsyncClick(Sender: TObject;
EventParams: TStringList);
begin
Session.UpdateHeartbeat;
end;
Intraweb supports TIWTimer, so sending a timestamp to the database should be pretty straightforward. Specifics of coding depend on detailed specifications.