Sometimes I experience random crashes in my Delphi program. My program halts, and the Debugger outputs:
Invalid address specified to RtlFreeHeap( 06450000, 08387460 )
What does that mean? And what can possibly cause it?
This is where the CPU Inspector stopped:
77BA0845 C6052582BD7700 mov byte ptr [$77bd8225],$00
Please note that they are very random (for me). Sometimes they don't appear at all.
I am using the Skype4COM.dll from Skype - there's no source though.
In case you need it, here is the code. I have commented most of the calls to Synchronize, so you know what they do.
////////////////////////////////////////////////////////////////////////////////
/// Execute
////////////////////////////////////////////////////////////////////////////////
procedure TContactDeletor.Execute;
Var
I : Integer;
UserObj : PUser;
User : IUser;
PauseEvent : TEvent;
begin
inherited;
FreeOnTerminate := True;
if Terminated then
Exit;
CoInitialize(Nil);
// The F-Flags are to make sure TSkype events do not fire (from my Main Thread)
FAllowUI := False;
FUserIsBeingDeleted := False;
FUseGroupUsersEvent := False;
FUseRenameEvent := False;
SkypeThr := TSkype.Create(Nil);
SkypeThr.Attach(10,False);
SkypeThr.Cache := False;
MyList := TStringList.Create;
PauseEvent := TEvent.Create(True);
try
// This fills my Stringlist
Synchronize(GrabList);
if Terminated then Exit;
iMax := MyList.Count;
// This sets the Max of my Progressbar
Synchronize(SetMax);
Try
for I := 0 to MyList.Count - 1 do
begin
{while SkypeThr.AttachmentStatus <> apiAttachSuccess do
begin
SkypeThr.Attach(10,False);
Synchronize(Procedure Begin Log('Skype Unavailable - Trying to reconnect ...'); End);
PauseEvent.WaitFor(5000);
end; }
CurUser := '';
User := SkypeThr.User[MyList[I]];
CurUser := MyList[I];
Try
User.IsAuthorized := False;
User.BuddyStatus := budDeletedFriend;
Except on E:Exception do
begin
ExErr := E.Message;
ExLog := 'Error while deleting contacts: ';
ExMsg := 'An Error has occured while deleting contacts: ';
Synchronize(
Procedure
Begin
Log(ExLog+ExErr+sLineBreak+' - Last logged Handle: '+CurUser);
End
);
end;
end;
iProgress := I+1;
// This updates my log and my progressbar.
Synchronize(UpdatePG);
PauseEvent.WaitFor(100);
if (I mod 200 = 0) and (I > 0) then
begin
// Calls to Synchronize updates my log
Synchronize(SyncPauseBegin);
PauseEvent.WaitFor(3000);
Synchronize(SyncPauseEnd);
end;
end;
// Except
Except on E:Exception do
begin
ExErr := E.Message;
ExLog := 'Error while deleting contacts: ';
ExMsg := 'An Error has occured while deleting contacts: ';
Synchronize(
Procedure
Begin
Log(ExMsg+ExErr+sLineBreak+' - Last logged Handle: '+CurUser);
ErrMsg(ExMsg+ExErr+sLineBreak+sLineBreak+' - Last logged Handle: '+CurUser);
End
);
Exit;
end;
end;
// This synchronizes my visual list.
Synchronize(SyncList);
finally
FUserIsBeingDeleted := False;
FUseGroupUsersEvent := True;
FUseRenameEvent := True;
FAllowUI := True;
Synchronize(
Procedure
Begin
frmMain.UpdateStatusBar;
PleaseWait(False);
ToggleUI(True);
end);
PauseEvent.Free;
SkypeThr.Free;
MyList.Free;
CoUninitialize;
end;
end;
Najem was correct, it is because your heap is corrupted. To debug it easier, you should enable PageHeap, also, use the debug CRT (or debug delphi runtime) as much as possiable until you find out what's corrupting your memory.
A lot of the time, the corruption may only spill over a few bytes. Then your application can run fine for a very long time, so you will not notice anything wrong until much later, if at all.
Try to exit your application cleanly when your looking for memory corruption bugs, dont just stop the debugger, when your process is exiting, it should "touch" most of the memory it allocated earlier and it will give you a chance to detect the failure.
Related
I have a Delphi Service app. Indy TCP server and many clients (up to 50), ADO connection to Firebird and simply network exchange. App randomly crashes (may be workin 7 days, may be 1 hour) with next event (for example):
Имя сбойного приложения: rollcontrol.exe, версия: 1.1.20.2, метка времени: 0x60acd5f2
Имя сбойного модуля: ntdll.dll, версия: 6.3.9600.19678, метка времени: 0x5e82c0f7
Код исключения: 0xc0000005
Смещение ошибки: 0x00058def
Идентификатор сбойного процесса: 0x4178
or:
Имя сбойного приложения: rollcontrol.exe, версия: 1.1.1.9, метка времени: 0x607b239c
Имя сбойного модуля: msvcrt.dll, версия: 7.0.9600.16384, метка времени: 0x52158ff5
Код исключения: 0xc0000005
Смещение ошибки: 0x00009e80
All jobs in app makes in anonimius threads or in tcp/ip connections threads. All code in each thread executed in try except statments. There no memory leaks or growing threads count. The main code of service thread very simple:
procedure TRollControl_Svc.ServiceExecute(Sender: TService);
begin
while not Terminated do
try
ServiceThread.ProcessRequests(False);
ServiceThread.Sleep(100);
except
on e : exception do LogException('ServiceExecute', E);
end;
end;
How I can handled this exception and prevent app crash? How it possible to crash service thread with two simple lines of code?
Thanks
UPDATE: Example of connections to DB:
function TRollControl_Svc.GetNodeIdByIP(ip: string): integer;
Var
SQLConnection : TADOConnection;
SQLQuery : TADOQuery;
Thread : TThread;
fResult : integer;
begin
fResult := 0;
try
Thread := nil;
Thread := TThread.CreateAnonymousThread(
procedure
begin
try
SQLConnection := nil;
SQLQuery := nil;
CoInitialize(nil);
SQLConnection := TADOConnection.Create(nil);
SQLConnection.ConnectionString := 'Provider=MSDASQL.1;Password=' + Psw + ';Persist Security Info=True;User ID=' + Usr + ';Data Source=' + Srv ;
SQLConnection.LoginPrompt := false;
SQLQuery := TADOQuery.Create(nil);
SQLQuery.Connection := SQLConnection;
SQLQuery.LockType := ltReadOnly;
try SQLConnection.Open; except SQLConnection.Open; end;
SQLConnection.BeginTrans;
SQLQuery.Close;
SQLQuery.SQL.Text := 'select nodes.* from nodes where nodes.ip = :ip';
SQLQuery.Parameters.ParamByName('ip').Value := ip;
try SQLQuery.Open; except SQLQuery.Open; end;
if SQLQuery.IsEmpty then exit;
fResult := SQLQuery.FieldByName('ID').AsInteger;
if SQLConnection.InTransaction then
SQLConnection.CommitTrans;
finally
TryFree(SQLQuery);
TryFree(SQLConnection);
CoUninitialize;
end;
end
);
Thread.FreeOnTerminate := false;
Thread.Start;
Thread.WaitFor;
finally
TryFree(Thread);
end;
result := fResult;
end;
Error Handling
This isn't an answer as to what is causing your problem, but I thought it probably wouldn't be clear in a comment.
In languages that support structured exception handling the language gives the programmer an opportunity to fail gracefully when things don't work. That's not how you are using it. From your example anonymous thread you have:
try SQLConnection.Open; except SQLConnection.Open; end;
So you are told that the connection can't be made and instead of responding to that situation you go ahead and attempt to connect again. There are lots of reasons why a connection may not work, some of those are transient so the attempt may work a little later but if you simply try doing it again without any pause it seems reasonable to expect it to fail again.
It's obviously important to catch errors, but you have to have appropriate failure paths.
I have no way of knowing if this is related to what's actually going wrong.
I found the reason. The problem was in the ADO source codes (Data.Win.ADODB.pas):
procedure RefreshFromOleDB;
var
I: Integer;
ParamCount: ULONG_PTR;
ParamInfo: PDBParamInfoArray;
NamesBuffer: POleStr;
Name: WideString;
Parameter: _Parameter;
Direction: ParameterDirectionEnum;
OLEDBCommand: ICommand;
OLEDBParameters: ICommandWithParameters;
CommandPrepare: ICommandPrepare;
begin
OLEDBCommand := (Command.CommandObject as ADOCommandConstruction).OLEDBCommand as ICommand;
OLEDBCommand.QueryInterface(ICommandWithParameters, OLEDBParameters);
OLEDBParameters.SetParameterInfo(0, nil, nil); // ----- Error here
if Assigned(OLEDBParameters) then
begin
ParamInfo := nil;
NamesBuffer := nil;
try
OLEDBCommand.QueryInterface(ICommandPrepare, CommandPrepare);
if Assigned(CommandPrepare) then CommandPrepare.Prepare(0);
if OLEDBParameters.GetParameterInfo(ParamCount, PDBPARAMINFO(ParamInfo), #NamesBuffer) = S_OK then
for I := 0 to ParamCount - 1 do//
begin
{ When no default name, fabricate one like ADO does }
if ParamInfo[I].pwszName = nil then
Name := 'Param' + IntToStr(I+1) else { Do not localize }
Name := ParamInfo[I].pwszName;
{ ADO maps DBTYPE_BYTES to adVarBinary }
if ParamInfo[I].wType = DBTYPE_BYTES then ParamInfo[I].wType := adVarBinary;
{ ADO maps DBTYPE_STR to adVarChar }
if ParamInfo[I].wType = DBTYPE_STR then ParamInfo[I].wType := adVarChar;
{ ADO maps DBTYPE_WSTR to adVarWChar }
if ParamInfo[I].wType = DBTYPE_WSTR then ParamInfo[I].wType := adVarWChar;
Direction := ParamInfo[I].dwFlags and $F;
{ Verify that the Direction is initialized }
if Direction = adParamUnknown then Direction := adParamInput;
Parameter := Command.CommandObject.CreateParameter(Name, ParamInfo[I].wType, Direction, ParamInfo[I].ulParamSize, EmptyParam);
Parameter.Precision := ParamInfo[I].bPrecision;
Parameter.NumericScale := ParamInfo[I].bScale;
//if ParamInfo[I].dwFlags and $FFFFFFF0 <= adParamSigned + adParamNullable + adParamLong then
Parameter.Attributes := ParamInfo[I].dwFlags and $FFFFFFF0; { Mask out Input/Output flags }
AddParameter.FParameter := Parameter;
end;
finally
if Assigned(CommandPrepare) then CommandPrepare.Unprepare;
if (ParamInfo <> nil) then GlobalMalloc.Free(ParamInfo);
if (NamesBuffer <> nil) then GlobalMalloc.Free(NamesBuffer);
end;
end;
end;
Line
OLEDBParameters.SetParameterInfo(0, nil, nil)
executed before
if Assigned(OLEDBParameters)
I moved this line after checking on nil and all working fine
I managed to isolate the problem. Errors occur periodically when working with ADO. If I try to use TADOQuery objects again, the application more susceptible to crashes. What I've done:
System.NeverSleepOnMMThreadContention: = false;
Significantly reduces errors when working with ADO
All uses of TADOQuery are single use.
For example it was:
for ii := 0 to SettingsXML.Root.NamedItem['sql_clear_base'].NamedItem['XML'].Count - 1 do
begin
try
SQLQuery.Close;
SQLQuery.SQL.Text := SettingsXML.Root.NamedItem['sql_clear_base'].NamedItem['XML'][ii].AsString;
SQLQuery.ExecSQL;
except
on e : exception do LogException('ClearBase', '', E);
end;
end;
Became:
for ii := 0 to SettingsXML.Root.NamedItem['sql_clear_base'].NamedItem['XML'].Count - 1 do
begin
SQLQuery := nil;
try
SQLQuery := TADOQuery.Create(nil);
SQLQuery.Connection := SQLConnection;
try
SQLQuery.Close;
SQLQuery.SQL.Text := SettingsXML.Root.NamedItem['sql_clear_base'].NamedItem['XML'][ii].AsString;
SQLQuery.ExecSQL;
except
on e : exception do LogException('ClearBase', '', E);
end;
finally
TryFree(SQLQuery);
end;
end;
I make self-control:
main procces started as windows service (process A)
process A starts a copy of itself as B
one per minutes A check if B alive and restart if not
one per minutes B check if A alive and restart if not
check - simple TCP packet and answer
For example:
TThread.CreateAnonymousThread(
procedure
var tcpClient : TidTCPClient;
begin
tcpClient := nil;
LastKeepAlive := Date + Time;
while ServerMode do
begin
try
if not Assigned(tcpClient) then
begin
tcpClient := TIdTCPClient.Create(nil);
tcpClient.Host := '127.0.0.1';
tcpClient.Port := RollControl_Svc.TCPServer.Bindings[0].Port;
tcpClient.Connect;
tcpClient.IOHandler.ReadTimeout := 1000;
end;
tcpClient.IOHandler.Write(START_PACKET + #0 + END_PACKET);
tcpClient.IOHandler.ReadString(3);
LastKeepAlive := Date + Time;
except
TryFree(tcpClient);
end;
sleep(15 * 1000);
end;
end).Start;
TThread.CreateAnonymousThread(
procedure
Var Res: TRequestResult;
begin
while ServerMode do
begin
if Date + Time - LastKeepAlive > OneMinute then
begin
Res.Clear('', '');
Res.Nodes_ID := -1;
Res.Data_In := 'KeepAlive';
Res.Data_Out := 'Exception: ExitProcess(1)';
try
Log(Res, true);
finally
ExitProcess(1);
end;
end;
sleep(1000);
end;
end).Start;
P.S. Local tests never crashed applications. The program simply proceed a million requests (connect, request, disconnect), there are no memory leaks or failures. On several clients servers are crashed. In the future I want to port to Lazarus to use ODBC directly insteed ADO
I'm using TIdFTP (Indy 10.6) for a client application and I need to be able to copy all files from one folder on the server to another. Can this be done?
I know how to rename or move a file, we can use TIdFTP.Rename(Src, Dst).
How about the copy? Would I need to use Get() and Put() with a new path / name, knowing that the number of files in the server can exceed 500,000 files.
In our company, we have some files whose size exceeds 1.5 GB. By using my code, it consumes a lot of memory and the file is not copied from one directory to another: in less code, the source directory is named "Fichiers" and the destination directory is named "Sauvegardes".
Here is my code:
var
S , directory : String;
I: Integer;
FichierFTP : TMemoryStream;
begin
IdFTP1.Passive := True;
idftp1.ChangeDir('/Fichiers/');
IdFTP1.List();
if IdFTP1.DirectoryListing.Count > 0 then begin
IdFTP1.List();
for I := 0 to IdFTP1.DirectoryListing.Count-1 do begin
with IdFTP1.DirectoryListing.Items[I] do begin
if ItemType = ditFile then begin
FichierFTP := TMemoryStream.Create;
S := FileName;
idftp1.Get( FileName , FichierFTP , false );
Application.ProcessMessages
idftp1.ChangeDir('/Sauvegardes/' );
idftp1.Put(FichierFTP , S );
Application.ProcessMessages;
FichierFTP.Free;
end;
end;
end;
IdFTP1.Disconnect;
end;
Does anyone have any experience with this? How can I change my code to resolve this problem?
There are no provisions in the FTP protocol, and thus no methods in TIdFTP, to copy/move multiple files at a time. Only to copy/move individual files one at a time.
Moving a file from one FTP folder to another is easy, that can be done with the TIdFTP.Rename() method. However, copying a file typically requires issuing separate commands to download the file locally first and then re-upload it to the new path.
Some FTP servers support custom commands for copying files, so that you do not need to download/upload them locally. For example, ProFTPD's mod_copy module implements SITE CPFR/CPTO commands for this purpose. If your FTP server supports such commands, you can use the TIdFTP.Site() method, eg:
Item := IdFTP1.DirectoryListing[I];
if Item.ItemType = ditFile then
begin
try
IdFTP1.Site('CPFR ' + Item.FileName);
IdFTP1.Site('CPTO /Sauvegardes/' + Item.FileName);
except
// fallback to another transfer option, see further below...
end;
end;
If that does not work, another possibility to avoid having to copy each file locally is to use a site-to-site transfer between 2 separate TIdFTP connections to the same FTP server. If the server allows this, you can use the TIdFTP.SiteToSiteUpload() and TIdFTP.SiteToSiteDownload() methods to make the server transfer files to itself, eg:
IdFTP2.Connect;
...
Item := IdFTP1.DirectoryListing[I];
if Item.ItemType = ditFile then
begin
try
IdFTP1.SiteToSiteUpload(IdFTP2, Item.FileName, '/Sauvegardes/' + Item.FileName);
except
try
IdFTP2.SiteToSiteDownload(IdFTP1, Item.FileName, '/Sauvegardes/' + Item.FileName);
except
// fallback to another transfer option, see further below...
end;
end;
end;
...
IdFTP2.Disconnect;
But, if using such commands is simply not an option, then you will have to resort to downloading each file locally and then re-uploading it. When copying a large file in this manner, you should use TFileStream (or similar) instead of TMemoryStream. Do not store large files in memory. Not only do you risk a memory error if the memory manager can't allocate enough memory to hold the entire file, but once that memory has been allocated and freed, the memory manager will hold on to it for later reuse, it does not get returned back to the OS. This is why you end up with such high memory usage when you transfer large files, even after all transfers are finished.
If you really want to use a TMemoryStream, use it for smaller files only. You can check each file's size on the server (either via TIdFTPListItem.Size if available, otherwise via TIdFTP.Size()) before downloading the file, and then choose an appropriate TStream-derived class to use for that transfer, eg:
const
MaxMemoryFileSize: Int64 = ...; // for you to choose...
var
...
FichierFTP : TStream;
LocalFileName: string;
RemoteFileSize: Int64;
Item := IdFTP1.DirectoryListing[I];
if Item.ItemType = ditFile then
begin
LocalFileName := '';
if Item.SizeAvail then
RemoteFileSize := Item.Size
else
RemoteFileSize := IdFTP1.Size(Item.FileName);
if (RemoteFileSize >= 0) and (RemoteFileSize <= MaxMemoryFileSize) then
begin
FichierFTP := TMemoryStream.Create;
end else
begin
LocalFileName := MakeTempFilename;
FichierFTP := TFileStream.Create(LocalFileName, fmCreate);
end;
try
IdFTP1.Get(Item.FileName, FichierFTP, false);
IdFTP1.Put(FichierFTP, '/Sauvegardes/' + Item.FileName, False, 0);
finally
FichierFTP.Free;
if LocalFileName <> '' then
DeleteFile(LocalFileName);
end;
end;
There are other optimizations you can make to this, for instance creating a single TMemoryStream with a pre-sized Capacity and then reuse it for multiple transfers that will not exceed that Capacity.
So, putting this all together, you could end up with something like the following:
var
I: Integer;
Item: TIdFTPListItem;
SourceFile, DestFile: string;
IdFTP2: TIdFTP;
CanAttemptRemoteCopy: Boolean;
CanAttemptSiteToSite: Boolean;
function CopyFileRemotely: Boolean;
begin
Result := False;
if CanAttemptRemoteCopy then
begin
try
IdFTP1.Site('CPFR ' + SourceFile);
IdFTP1.Site('CPTO ' + DestFile);
except
CanAttemptRemoteCopy := False;
Exit;
end;
Result := True;
end;
end;
function CopyFileSiteToSite: Boolean;
begin
Result := False;
if CanAttemptSiteToSite then
begin
try
if IdFTP2 = nil then
begin
IdFTP2 := TIdFTP.Create(nil);
IdFTP.Host := IdFTP1.Host;
IdFTP.Port := IdFTP1.Port;
IdFTP.UserName := IdFTP1.UserName;
IdFTP.Password := IdFTP1.Password;
// copy other properties as needed...
IdFTP2.Connect;
end;
try
IdFTP1.SiteToSiteUpload(IdFTP2, SourceFile, DestFile);
except
IdFTP2.SiteToSiteDownload(IdFTP1, SourceFile, DestFile);
end;
except
CanAttemptSiteToSite := False;
Exit;
end;
Result := True;
end;
end;
function CopyFileManually: Boolean;
const
MaxMemoryFileSize: Int64 = ...;
var
FichierFTP: TStream;
LocalFileName: String;
RemoteFileSize: Int64;
begin
Result := False;
try
if Item.SizeAvail then
RemoteFileSize := Item.Size
else
RemoteFileSize := IdFTP1.Size(SourceFile);
if (RemoteFileSize >= 0) and (RemoteFileSize <= MaxMemoryFileSize) then
begin
LocalFileName := '';
FichierFTP := TMemoryStream.Create;
end else
begin
LocalFileName := MakeTempFilename;
FichierFTP := TFileStream.Create(LocalFileName, fmCreate);
end;
try
IdFTP1.Get(SourceFile, FichierFTP, false);
IdFTP1.Put(FichierFTP, DestFile, False, 0);
finally
FichierFTP.Free;
if LocalFileName <> '' then
DeleteFile(LocalFileName);
end;
except
Exit;
end;
Result := True;
end;
begin
CanAttemptRemoteCopy := True;
CanAttemptSiteToSite := True;
IdFTP2 := nil;
try
IdFTP1.Passive := True;
IdFTP1.ChangeDir('/Fichiers/');
IdFTP1.List;
for I := 0 to IdFTP1.DirectoryListing.Count-1 do
begin
Item := IdFTP1.DirectoryListing[I];
if Item.ItemType = ditFile then
begin
SourceFile := Item.FileName;
DestFile := '/Sauvegardes/' + Item.FileName;
if CopyFileRemotely then
Continue;
if CopyFileSiteToSite then
Continue;
if CopyFileManually then
Continue;
// failed to copy file! Do something...
end;
end;
finally
IdFTP2.Free;
end;
IdFTP1.Disconnect;
end;
I need to Start a service using Delphi Windows application.It is working fine in Windows 7 but not working in Windows 8.1 .I have used the following code
function ServiceStart(sMachine,sService : string ) : boolean;
var
schm,schs : SC_Handle;
ss : TServiceStatus;
psTemp : PChar;
dwChkP : DWord;
begin
ss.dwCurrentState := 0;
schm := OpenSCManager(PChar(sMachine),Nil,SC_MANAGER_CONNECT);
if(schm > 0)then
begin
schs := OpenService(schm,PChar(sService),SERVICE_START or SERVICE_QUERY_STATUS);
if(schs > 0)then
begin
psTemp := Nil;
if(StartService(schs,0,psTemp))then
begin
if(QueryServiceStatus(schs,ss))then
begin
while(SERVICE_RUNNING <> ss.dwCurrentState)do
begin
dwChkP := ss.dwCheckPoint;
Sleep(ss.dwWaitHint);
if(not QueryServiceStatus(schs,ss))then
begin
break;
end;
if(ss.dwCheckPoint < dwChkP)then
begin
break;
end;
end;
end;
end;
CloseServiceHandle(schs);
end;
CloseServiceHandle(schm);
end;
Result := SERVICE_RUNNING = ss.dwCurrentState;
end;
procedure TForm1.BBSerStatusClick(Sender: TObject);
begin
ServiceStart('','SERVTEST');
end;
Note: SERVTEST it is service application.
Can anyone help me?
I see that you are using code copied from here.
if(schm > 0)then and if(schs > 0)then should be changed to if(schm <> 0)then and if(schs <> 0) then instead. The only failure value in this situation is 0 (some APIs use INVALID_HANDLE_VALUE instead, but the SCM API does not). Any other value is a valid handle. Handles are not really integers (although Delphi declares them as such), so you should not treat them as integers. They are arbitrary values that are not meant to be interpreted, they are meant to be used as-is. If you do not get back an actual failure value (in this case, 0), then the call was successful regardless of the value actully returned.
The handling of ss.dwCurrentState is a little off, too. Instead of looping while ss.dwCurrentState is not SERVICE_RUNNING, loop while ss.dwCurrentState is SERVICE_START_PENDING instead. If something goes wrong and the service never enters the SERVICE_RUNNING state, the loop will run forever, unless QueryServiceStatus() itself fails. And I would not suggest relying on ss.dwCheckPoint because not all services implement it correctly (in fact, Delphi's own TService does not - see QC #1006 TService.ReportStatus reports incorrect CheckPoint).
Try something more like the following. It differentiates between SCM API failures and Service start failures, but also does extra error checking to handle certain errors that are not actually fatal errors:
function ServiceStart(sMachine, sService : string) : Boolean;
var
schm, schs : SC_HANDLE;
ss : TServiceStatus;
begin
schm := OpenSCManager(PChar(sMachine), nil, SC_MANAGER_CONNECT);
if (schm = 0) then RaiseLastOSError;
try
schs := OpenService(schm, PChar(sService), SERVICE_START or SERVICE_QUERY_STATUS);
if (schs = 0) then RaiseLastOSError;
try
// NOTE: if you use a version of Delphi that incorrectly declares
// StartService() with a 'var' lpServiceArgVectors parameter, you
// can't pass a nil value directly in the 3rd parameter, you would
// have to pass it indirectly as either PPChar(nil)^ or PChar(nil^)
if not StartService(schs, 0, nil) then
begin
Result := ERROR_SERVICE_ALREADY_RUNNING = GetLastError();
if not Result then RaiseLastOSError;
Exit;
end;
repeat
if not QueryServiceStatus(schs, ss) then
begin
if (ERROR_SERVICE_NOT_ACTIVE <> GetLastError()) then RaiseLastOSError;
Result := False;
Exit;
end;
if (SERVICE_START_PENDING <> ss.dwCurrentState) then Break;
Sleep(ss.dwWaitHint);
until False;
Result := SERVICE_RUNNING = ss.dwCurrentState;
finally
CloseServiceHandle(schs);
end;
finally
CloseServiceHandle(schm);
end;
end;
Or, here is a (modified) version of Microsoft's example, which also includes handling if the service is in SERVICE_STOP_PENDING state before starting it (I removed timeout logic since it is based on dwCheckPoint handling):
Starting a Service:
function ServiceStart(sMachine, sService : string) : Boolean;
var
schSCManager,
schService : SC_HANDLE;
ssStatus : TServiceStatus;
begin
// Get a handle to the SCM database.
schSCManager := OpenSCManager(PChar(sMachine), nil, SC_MANAGER_CONNECT);
if (schSCManager = 0) then RaiseLastOSError;
try
// Get a handle to the service.
schService := OpenService(schSCManager, PChar(sService), SERVICE_START or SERVICE_QUERY_STATUS);
if (schService = 0) then RaiseLastOSError;
try
// Check the status in case the service is not stopped.
if not QueryServiceStatus(schService, ssStatus) then
begin
if (ERROR_SERVICE_NOT_ACTIVE <> GetLastError()) then RaiseLastOSError;
ssStatus.dwCurrentState := SERVICE_STOPPED;
end;
// Check if the service is already running
if (ssStatus.dwCurrentState <> SERVICE_STOPPED) and ssStatus.dwCurrentState <> SERVICE_STOP_PENDING) then
begin
Result := True;
Exit;
end;
// Wait for the service to stop before attempting to start it.
while (ssStatus.dwCurrentState = SERVICE_STOP_PENDING) do
begin
// Do not wait longer than the wait hint. A good interval is
// one-tenth of the wait hint but not less than 1 second
// and not more than 10 seconds.
dwWaitTime := ssStatus.dwWaitHint div 10;
if (dwWaitTime < 1000) then
dwWaitTime := 1000
else if (dwWaitTime > 10000) then
dwWaitTime := 10000;
Sleep(dwWaitTime);
// Check the status until the service is no longer stop pending.
if not QueryServiceStatus(schService, ssStatus) then
begin
if (ERROR_SERVICE_NOT_ACTIVE <> GetLastError()) then RaiseLastOSError;
Break;
end;
end;
// Attempt to start the service.
// NOTE: if you use a version of Delphi that incorrectly declares
// StartService() with a 'var' lpServiceArgVectors parameter, you
// can't pass a nil value directly in the 3rd parameter, you would
// have to pass it indirectly as either PPChar(nil)^ or PChar(nil^)
if not StartService(schService, 0, nil) then RaiseLastOSError;
// Check the status until the service is no longer start pending.
if not QueryServiceStatus(schService, ssStatus) then
begin
if (ERROR_SERVICE_NOT_ACTIVE <> GetLastError()) then RaiseLastOSError;
ssStatus.dwCurrentState := SERVICE_STOPPED;
end;
while (ssStatus.dwCurrentState = SERVICE_START_PENDING) do
begin
// Do not wait longer than the wait hint. A good interval is
// one-tenth the wait hint, but no less than 1 second and no
// more than 10 seconds.
dwWaitTime := ssStatus.dwWaitHint div 10;
if (dwWaitTime < 1000) then
dwWaitTime := 1000
else if (dwWaitTime > 10000) then
dwWaitTime := 10000;
Sleep(dwWaitTime);
// Check the status again.
if not QueryServiceStatus(schService, ssStatus) then
begin
if (ERROR_SERVICE_NOT_ACTIVE <> GetLastError()) then RaiseLastOSError;
ssStatus.dwCurrentState := SERVICE_STOPPED;
Break;
end;
end;
// Determine whether the service is running.
Result := (ssStatus.dwCurrentState = SERVICE_RUNNING);
finally
CloseServiceHandle(schService);
end;
finally
CloseServiceHandle(schSCManager);
end;
end;
I have been playing around with some code to send mail using MAPI in my Delphi XE7 program.
I have managed to get the To, Cc and Bcc working together with fileattachment, but when the mail is send by the client (in this case Outlook 2010) the program crashes and I simply can't figure out where I am am doing something wrong - I might be staring blind on the code.
I have made a small example with the code in a file in my dropbox
dl.dropboxusercontent.com/u/65392149/Mapi_MCVE.ZIP
The MAPI function looks like this
function SendMailMAPI(const aFrom, aTo, aCc, aBcc, aSubject, aBody: string; aMailFiles: TStringList; aReceipt: boolean): boolean;
var
MapiStatus: DWord;
MapiMessage: TMapiMessage;
MapiOrigin: TMapiRecipDesc;
MapiRecipient: array of TMapiRecipDesc;
MapiFiles: PMapiFileDesc;
RecipientsTo: TStringlist;
RecipientsCc: TStringlist;
RecipientsBcc: TStringlist;
RecipientsCount: integer;
FilesCount: Integer;
i: integer;
Filename: string;
begin
MapiStatus := SUCCESS_SUCCESS;
Result := True;
MapiFiles := nil;
FillChar(MapiMessage, Sizeof(TMapiMessage), 0);
if aReceipt then
MapiMessage.flFlags := MAPI_RECEIPT_REQUESTED;
MapiMessage.lpszSubject := PAnsiChar(AnsiString(aSubject));
MapiMessage.lpszNoteText := PAnsiChar(AnsiString(aBody));
FillChar(MapiOrigin, Sizeof(TMapiRecipDesc), 0);
MapiOrigin.lpszName := PAnsiChar(AnsiString(aFrom));
MapiOrigin.lpszAddress := PAnsiChar(AnsiString(aFrom));
MapiMessage.lpOriginator := nil;
FilesCount := aMailFiles.Count;
if FilesCount > 0 then
begin
GetMem(MapiFiles, SizeOf(TMapiFileDesc) * FilesCount);
for i := 0 to FilesCount - 1 do
begin
FileName := aMailfiles[i];
MapiFiles[i].ulReserved := 0;
MapiFiles[i].flFlags := 0;
MapiFiles[i].nPosition := ULONG($FFFFFFFF);
MapiFiles[i].lpszPathName := PAnsiChar(AnsiString(FileName));
MapiFiles[i].lpszFileName := PAnsiChar(AnsiString(ExtractFileName(FileName)));
MapiFiles[i].lpFileType := nil;
end;
MapiMessage.nFileCount := FilesCount;
MapiMessage.lpFiles := #MapiFiles^;
end;
RecipientsCount := 0;
RecipientsTo := TStringlist.Create;
RecipientsCc := TStringlist.Create;
RecipientsBcc := TStringlist.Create;
RecipientsTo.Delimiter := ';';
RecipientsCc.Delimiter := ';';
RecipientsBcc.Delimiter := ';';
try
if aTo <> '' then
begin
RecipientsTo.DelimitedText := aTo;
RecipientsCount := RecipientsCount + RecipientsTo.Count;
end;
if aCc <> '' then
begin
RecipientsCc.DelimitedText := aCc;
RecipientsCount := RecipientsCount + RecipientsCc.Count;
end;
if aBcc <> '' then
begin
RecipientsBcc.DelimitedText := aBcc;
RecipientsCount := RecipientsCount + RecipientsBcc.Count;
end;
FillChar(MapiRecipient, Sizeof(TMapiRecipDesc) * RecipientsCount, 0);
SetLength(MapiRecipient, RecipientsCount);
RecipientsCount := 0;
if RecipientsTo.Count > 0 then
begin
MapiRecipient[RecipientsCount].ulRecipClass := MAPI_TO;
for i := 0 to RecipientsTo.Count - 1 do
begin
MapiRecipient[RecipientsCount].lpszName := PAnsiChar(AnsiString(RecipientsTo[i]));
MapiRecipient[RecipientsCount].lpszAddress := PAnsiChar(AnsiString(RecipientsTo[i]));
Inc(RecipientsCount);
end;
end;
if RecipientsCc.Count > 0 then
begin
MapiRecipient[RecipientsCount].ulRecipClass := MAPI_CC;
for i := 0 to RecipientsCc.Count - 1 do
begin
MapiRecipient[RecipientsCount].lpszName := PAnsiChar(AnsiString(RecipientsCc[i]));
MapiRecipient[RecipientsCount].lpszAddress := PAnsiChar(AnsiString(RecipientsCc[i]));
Inc(RecipientsCount);
end;
end;
if RecipientsBcc.Count > 0 then
begin
MapiRecipient[RecipientsCount].ulRecipClass := MAPI_BCC;
for i := 0 to RecipientsBcc.Count - 1 do
begin
MapiRecipient[RecipientsCount].lpszName := PAnsiChar(AnsiString(RecipientsBcc[i]));
MapiRecipient[RecipientsCount].lpszAddress := PAnsiChar(AnsiString(RecipientsBcc[i]));
Inc(RecipientsCount);
end;
end;
MapiMessage.nRecipCount := RecipientsCount;
MapiMessage.lpRecips:= Pointer(MapiRecipient);
finally
RecipientsTo.Free;
RecipientsCc.Free;
RecipientsBcc.Free;
end;
try
MapiStatus := MapiSendMail(0, Application.MainForm.Handle, MapiMessage, MAPI_LOGON_UI + MAPI_DIALOG, 0);
except
on E:Exception do
ShowMessage('U_Mailing.Mapi.SendMailMAPI: ' + E.Message);
end;
for i := 0 to FilesCount - 1 do
begin
System.AnsiStrings.StrDispose(MapiFiles[i].lpszPathName);
System.AnsiStrings.StrDispose(MapiFiles[i].lpszFileName);
end;
for i := 0 to RecipientsCount - 1 do
begin
System.AnsiStrings.StrDispose(MapiRecipient[i].lpszName);
System.AnsiStrings.StrDispose(MapiRecipient[i].lpszAddress);
end;
case MapiStatus of
MAPI_E_AMBIGUOUS_RECIPIENT:
Showmessage('A recipient matched more than one of the recipient descriptor structures and MAPI_DIALOG was not set. No message was sent.');
MAPI_E_ATTACHMENT_NOT_FOUND:
Showmessage('The specified attachment was not found; no message was sent.');
MAPI_E_ATTACHMENT_OPEN_FAILURE:
Showmessage('The specified attachment could not be opened; no message was sent.');
MAPI_E_BAD_RECIPTYPE:
Showmessage('The type of a recipient was not MAPI_TO, MAPI_CC, or MAPI_BCC. No message was sent.');
MAPI_E_FAILURE:
Showmessage('One or more unspecified errors occurred; no message was sent.');
MAPI_E_INSUFFICIENT_MEMORY:
Showmessage('There was insufficient memory to proceed. No message was sent.');
MAPI_E_LOGIN_FAILURE:
Showmessage('There was no default logon, and the user failed to log on successfully when the logon dialog box was displayed. No message was sent.');
MAPI_E_TEXT_TOO_LARGE:
Showmessage('The text in the message was too large to sent; the message was not sent.');
MAPI_E_TOO_MANY_FILES:
Showmessage('There were too many file attachments; no message was sent.');
MAPI_E_TOO_MANY_RECIPIENTS:
Showmessage('There were too many recipients; no message was sent.');
MAPI_E_UNKNOWN_RECIPIENT:
Showmessage('A recipient did not appear in the address list; no message was sent.');
MAPI_E_USER_ABORT:
Showmessage('The user canceled the process; no message was sent.');
else
Showmessage('MAPISendMail failed with an unknown error code.');
Result := False;
end;
end;
I can see two obvious mistakes. Firstly you use a lot of implicit temporary AnsiString variables whose lifetime is unclear. This happens whenever you do
PAnsiChar(AnsiString(...))
The compiler makes a temporary AnsiString local variable. You are relying on the compiler making enough of them, one for each distinct string.
When you do this inside a loop, the compiler will have one implicit local variable shared between all iterations. That's not enough. You might get away with this because the memory manager doesn't happen to re-use the memory. But your code is still wrong.
I would create a TList<AnsiString> to hold the numerous AnsiString variables. Every time you need to get a PAnsiChar do this:
astr := AnsiString(...);
TempAnsiStrings.Add(astr);
... := PAnsiChar(astr);
where TempAnsiStrings is your list that holds temporary AnsiString objects. Wrap this up in a nested function for ease of use.
function GetPAnsiChar(const str: string): PAnsiChar;
var
astr: AnsiString;
begin
astr := AnsiString(str);
TempAnsiStrings.Add(astr);
Result := PAnsiChar(astr);
end;
Obviously you need to instantiate the list, and destroy it, but I trust you already know how to do that.
Your other problem are the calls to StrDispose. You have to remove them since the compiler is managing lifetime. Call StrDispose to free memory allocated with StrNew or StrAlloc. You don't allocate this way so there is no place for StrDispose.
Rather than using explicit memory allocation for list of files, a dynamic array would be cleaner. This would have the other benefit of avoiding the possibility of leaking that your code currently has due to its missing finally block.
I have a public server(configured with indy 10) . some unknown clients are sending thousands of no content messages that it change the server's cpu usage to 50% . i have no firewall on my server , so i tried to block the unknown clients with this codes :
This is a function that works with a Timer :
var
i, j: integer;
begin
IX2 := IX2 + 1;
SetLength(ClientIPs, IX2);
ClientIPs[IX2 - 1] := StrIP;
j := 0;
for i := low(ClientIPs) to high(ClientIPs) do
begin
Application.ProcessMessages;
if ClientIPs[i] = StrIP then
j := j + 1;
end;
if j > 10 then
begin
Result := false;
exit;
end;
Result := true;
And it's my Timer code :
//Reset filtering measures
IX2 := 0;
SetLength(ClientIPs, 0);
So i use it in OnExecute event :
LogIP := AContext.Connection.Socket.Binding.PeerIP;
if IPFilter(LogIP) <> true then
begin
AContext.Connection.disconnect;
exit;
end;
//Get Data *********
Data := AContext.Connection.IOHandler.ReadLn();
finally , if a client sends many message in a short time , it will be disconnect . but there is a problem . in fact , after client disconnection , the Onexecute event is still working and i can not stop the operation Fully .anyway i need to block some IPs completely .
Thank you
The OnConnect event would be a better place to disconnect blacklisted IPs. The only reason to do the check in the OnExecute event is if the IP is not being blacklisted until after OnConnect has already been fired.
As for why OnExecute keeps running after you disconnect - the only way that can happen is if your OnExecute handler has a try..except block that is catching and discarding Indy's internal notifications. Any exception handling you do needs to re-raise EIdException-derived exceptions so the server can process them.
Followup to my earlier comment:
function TForm1.IPFilter(const StrIP: string): Boolean;
var
i, j: integer;
list: TList;
begin
j := 0;
list := IdTCPServer1.Contexts.LockList;
try
for i := 0 to list.Count-1 do
begin
if TIdContext(list[i]).Binding.PeerIP = StrIP then
Inc(j);
end;
Result := j <= 10;
finally
IdTCPServer1.Contexts.UnlockList;
end;
end;
procedure TForm1.IdTCPServer1Execute(AContext: TIdContext);
begin
// the simpliest way to force a disconnect and stop
// the calling thread is to raise an exception...
if not IPFilter(AContext.Binding.PeerIP) then
Abort();
// alternatively, if you call Disconnect(), make sure
// the IOHandler's InputBuffer is empty, or else
// AContext.Connection.Connected() will continue
// returning True!...
{if not IPFilter(AContext.Binding.PeerIP) then
begin
AContext.Connection.Disconnect;
AContext.Connection.IOHandler.InputBuffer.Clear;
Exit;
end;}
//Get Data *********
Data := AContext.Connection.IOHandler.ReadLn();
end;