Menu
▾
▴
jcl-checkins-diff
|
From: <ou...@us...> - 2012-02-17 20:09:31
|
Revision: 3732
http://jcl.svn.sourceforge.net/jcl/?rev=3732&view=rev
Author: outchy
Date: 2012-02-17 20:09:24 +0000 (Fri, 17 Feb 2012)
Log Message:
-----------
Mantis 5742: String to unsigned int conversions.
Modified Paths:
--------------
trunk/jcl/source/common/JclSysUtils.pas
Modified: trunk/jcl/source/common/JclSysUtils.pas
===================================================================
--- trunk/jcl/source/common/JclSysUtils.pas 2012-02-16 19:52:42 UTC (rev 3731)
+++ trunk/jcl/source/common/JclSysUtils.pas 2012-02-17 20:09:24 UTC (rev 3732)
@@ -596,6 +596,10 @@
function IntToBool(I: Integer): Boolean;
function BoolToInt(B: Boolean): Integer;
+function TryStrToCardinal(const Value: string; out Res: Cardinal): boolean;
+function StrToCardinalDef(const Value: string; const Default: Cardinal): Cardinal;
+function StrToCardinal(const Value: string): Cardinal;
+
const
{$IFDEF MSWINDOWS}
ListSeparator = ';';
@@ -3374,6 +3378,29 @@
Result := Ord(B);
end;
+function TryStrToCardinal(const Value: string; out Res: Cardinal): boolean;
+var i6: Int64;
+begin
+ Result := false;
+ if not TryStrToInt64(Value, i6) then exit;
+ if ( i6 < Low(Res)) or ( i6 > High(Res)) then exit;
+
+ Result := true;
+ Res := i6;
+end;
+
+function StrToCardinalDef(const Value: string; const Default: Cardinal): Cardinal;
+begin
+ if not TryStrToCardinal(Value, Result)
+ then Result := Default;
+end;
+
+function StrToCardinal(const Value: string): Cardinal;
+begin
+ if not TryStrToCardinal(Value, Result)
+ then raise EConvertError.Create('"'+Value+'" is not within range of Cardinal data type');
+end;
+
//=== RTL package information ================================================
function SystemTObjectInstance: TJclAddr;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ah...@us...> - 2012-03-09 12:43:21
|
Revision: 3766
http://jcl.svn.sourceforge.net/jcl/?rev=3766&view=rev
Author: ahuser
Date: 2012-03-09 12:43:15 +0000 (Fri, 09 Mar 2012)
Log Message:
-----------
Fixed deadlock when starting the Installers on a SSD.
CreatePipe doesn't create a pipe that supports overlapping, but the code assumed it. So if the sub-process started and terminated before the "Error-Out" data was read, the ReadFile() call would never return. I have now changed the Windows code to create a named pipe with FILE_FLAG_OVERLAPPED and fixed all the exceptions that were thrown due to not handling ERROR_IO_PENDING and ERROR_PIPE_BROKEN correctly.
Modified Paths:
--------------
trunk/jcl/source/common/JclSysUtils.pas
Modified: trunk/jcl/source/common/JclSysUtils.pas
===================================================================
--- trunk/jcl/source/common/JclSysUtils.pas 2012-03-09 10:29:12 UTC (rev 3765)
+++ trunk/jcl/source/common/JclSysUtils.pas 2012-03-09 12:43:15 UTC (rev 3766)
@@ -2751,20 +2751,44 @@
if not ReadFile(PipeInfo.PipeRead, PipeInfo.Buffer[0], BufferSize, NullDWORD^, @Overlapped) then
begin
Res := GetLastError;
- if Res = ERROR_BROKEN_PIPE then
- begin
- CloseHandle(PipeInfo.PipeRead);
- PipeInfo.PipeRead := 0;
- end
+ case Res of
+ ERROR_BROKEN_PIPE:
+ begin
+ CloseHandle(PipeInfo.PipeRead);
+ PipeInfo.PipeRead := 0;
+ end;
+ ERROR_IO_PENDING:
+ ;
else
{$IFDEF DELPHI11_UP}
RaiseLastOSError(Res);
{$ELSE}
RaiseLastOSError;
{$ENDIF DELPHI11_UP}
+ end;
end;
end;
+procedure InternalExecuteHandlePipeEvent(var PipeInfo: TPipeInfo; var Overlapped: TOverlapped);
+var
+ PipeBytesRead: DWORD;
+begin
+ if GetOverlappedResult(PipeInfo.PipeRead, Overlapped, PipeBytesRead, False) then
+ begin
+ InternalExecuteProcessBuffer(PipeInfo, PipeBytesRead);
+ // automatically launch the next read
+ InternalExecuteReadPipe(PipeInfo, Overlapped);
+ end
+ else
+ if GetLastError = ERROR_BROKEN_PIPE then
+ begin
+ CloseHandle(PipeInfo.PipeRead);
+ PipeInfo.PipeRead := 0;
+ end
+ else
+ RaiseLastOSError;
+end;
+
procedure InternalExecuteFlushPipe(var PipeInfo: TPipeInfo; var Overlapped: TOverlapped);
var
PipeBytesRead: DWORD;
@@ -2783,12 +2807,58 @@
end;
end;
+var
+ AsyncPipeCounter: Integer;
+
+// CreateAsyncPipe creates a pipe that uses overlapped reading.
+function CreateAsyncPipe(var hReadPipe, hWritePipe: THandle;
+ lpPipeAttributes: PSecurityAttributes; nSize: DWORD): BOOL;
+var
+ PipeName: string;
+ Error: DWORD;
+ PipeReadHandle, PipeWriteHandle: THandle;
+begin
+ Result := False;
+
+ if (@hReadPipe = nil) or (@hWritePipe = nil) then
+ begin
+ SetLastError(ERROR_INVALID_PARAMETER);
+ Exit;
+ end;
+
+ if nSize = 0 then
+ nSize := 4096;
+
+ InterlockedIncrement(AsyncPipeCounter);
+ PipeName := Format('\\.\Pipe\AsyncAnonPipe.%.8x.%.8x', [GetCurrentProcessId, AsyncPipeCounter]);
+
+ PipeReadHandle := CreateNamedPipe(PChar(PipeName), PIPE_ACCESS_INBOUND or FILE_FLAG_OVERLAPPED,
+ PIPE_TYPE_BYTE or PIPE_WAIT, 1, nSize, nSize, 120 * 1000, lpPipeAttributes);
+ if PipeReadHandle = 0 then
+ Exit;
+
+ PipeWriteHandle := CreateFile(PChar(PipeName), GENERIC_WRITE, 0, lpPipeAttributes, OPEN_EXISTING,
+ FILE_ATTRIBUTE_NORMAL {or FILE_FLAG_OVERLAPPED}, 0);
+ if PipeWriteHandle = INVALID_HANDLE_VALUE then
+ begin
+ Error := GetLastError;
+ CloseHandle(PipeReadHandle);
+ SetLastError(Error);
+ Exit;
+ end;
+
+ hReadPipe := PipeReadHandle;
+ hWritePipe := PipeWriteHandle;
+
+ Result := True;
+end;
+
function InternalExecute(CommandLine: string; AbortPtr: PBoolean; AbortEvent: TJclEvent;
var Output: string; OutputLineCallback: TTextHandler; RawOutput: Boolean;
MergeError: Boolean; var Error: string; ErrorLineCallback: TTextHandler; RawError: Boolean): Cardinal;
var
OutPipeInfo, ErrorPipeInfo: TPipeInfo;
- Index, PipeBytesRead: Cardinal;
+ Index: Cardinal;
{$IFDEF MSWINDOWS}
var
StartupInfo: TStartupInfo;
@@ -2804,10 +2874,11 @@
SecurityAttr.nLength := SizeOf(SecurityAttr);
SecurityAttr.lpSecurityDescriptor := nil;
SecurityAttr.bInheritHandle := True;
+
ResetMemory(OutPipeInfo, SizeOf(OutPipeInfo));
OutPipeInfo.TextHandler := OutputLineCallback;
OutPipeInfo.RawOutput := RawOutput;
- if not CreatePipe(OutPipeInfo.PipeRead, OutPipeInfo.PipeWrite, @SecurityAttr, 0) then
+ if not CreateAsyncPipe(OutPipeInfo.PipeRead, OutPipeInfo.PipeWrite, @SecurityAttr, 0) then
begin
Result := GetLastError;
Exit;
@@ -2818,13 +2889,17 @@
begin
ErrorPipeInfo.TextHandler := ErrorLineCallback;
ErrorPipeInfo.RawOutput := RawError;
- if not CreatePipe(ErrorPipeInfo.PipeRead, ErrorPipeInfo.PipeWrite, @SecurityAttr, 0) then
+ if not CreateAsyncPipe(ErrorPipeInfo.PipeRead, ErrorPipeInfo.PipeWrite, @SecurityAttr, 0) then
begin
Result := GetLastError;
+ CloseHandle(OutPipeInfo.PipeWrite);
+ CloseHandle(OutPipeInfo.PipeRead);
+ OutPipeInfo.Event.Free;
Exit;
end;
ErrorPipeInfo.Event := TJclEvent.Create(@SecurityAttr, False {automatic reset}, False {not flagged}, '' {anonymous});
end;
+
ResetMemory(StartupInfo, SizeOf(TStartupInfo));
StartupInfo.cb := SizeOf(TStartupInfo);
StartupInfo.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
@@ -2878,18 +2953,12 @@
WaitEvents[Index] := AbortEvent;
end;
// init the asynchronous reads
- OutOverlapped.Internal := 0;
- OutOverlapped.InternalHigh := 0;
- OutOverlapped.Offset := 0;
- OutOverlapped.OffsetHigh := 0;
+ ResetMemory(OutOverlapped, SizeOf(OutOverlapped));
OutOverlapped.hEvent := OutPipeInfo.Event.Handle;
InternalExecuteReadPipe(OutPipeInfo, OutOverlapped);
if not MergeError then
begin
- ErrorOverlapped.Internal := 0;
- ErrorOverlapped.InternalHigh := 0;
- ErrorOverlapped.Offset := 0;
- ErrorOverlapped.OffsetHigh := 0;
+ ResetMemory(ErrorOverlapped, SizeOf(ErrorOverlapped));
ErrorOverlapped.hEvent := ErrorPipeInfo.Event.Handle;
InternalExecuteReadPipe(ErrorPipeInfo, ErrorOverlapped);
end;
@@ -2904,21 +2973,13 @@
if Index = (WAIT_OBJECT_0 + 1) then
begin
// event on output
- if not GetOverlappedResult(OutPipeInfo.PipeRead, OutOverlapped, PipeBytesRead, False) then
- RaiseLastOSError;
- InternalExecuteProcessBuffer(OutPipeInfo, PipeBytesRead);
- // automatically launch the next read
- InternalExecuteReadPipe(OutpipeInfo, OutOverlapped);
+ InternalExecuteHandlePipeEvent(OutPipeInfo, OutOverlapped);
end
else
if (Index = (WAIT_OBJECT_0 + 2)) and not MergeError then
begin
// event on error
- if not GetOverlappedResult(ErrorPipeInfo.PipeRead, ErrorOverlapped, PipeBytesRead, False) then
- RaiseLastOSError;
- InternalExecuteProcessBuffer(ErrorPipeInfo, PipeBytesRead);
- // automatically launch the next read
- InternalExecuteReadPipe(ErrorPipeInfo, ErrorOverlapped);
+ InternalExecuteHandlePipeEvent(ErrorPipeInfo, ErrorOverlapped);
end
else
if ((Index = (WAIT_OBJECT_0 + 2)) and MergeError) or
@@ -2941,7 +3002,7 @@
if OutPipeInfo.PipeRead <> 0 then
// read data remaining in output pipe
InternalExecuteFlushPipe(OutPipeinfo, OutOverlapped);
- if (not MergeError) and (ErrorPipeInfo.PipeRead <> 0) then
+ if not MergeError and (ErrorPipeInfo.PipeRead <> 0) then
// read data remaining in error pipe
InternalExecuteFlushPipe(ErrorPipeInfo, ErrorOverlapped);
end;
@@ -2970,6 +3031,7 @@
{$ENDIF MSWINDOWS}
{$IFDEF UNIX}
var
+ PipeBytesRead: Cardinal;
Pipe: PIOFile;
Cmd: string;
begin
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ob...@us...> - 2012-05-02 08:07:45
|
Revision: 3786
http://jcl.svn.sourceforge.net/jcl/?rev=3786&view=rev
Author: obones
Date: 2012-05-02 08:07:34 +0000 (Wed, 02 May 2012)
Log Message:
-----------
Always terminate the process, or else it will leave it dangling, with all its handles opened. This is especially important when one of the text handlers triggers and exception
Modified Paths:
--------------
trunk/jcl/source/common/JclSysUtils.pas
Modified: trunk/jcl/source/common/JclSysUtils.pas
===================================================================
--- trunk/jcl/source/common/JclSysUtils.pas 2012-04-30 07:54:26 UTC (rev 3785)
+++ trunk/jcl/source/common/JclSysUtils.pas 2012-05-02 08:07:34 UTC (rev 3786)
@@ -2932,7 +2932,6 @@
AbortPtr := @InternalAbort;
// init the array of events to wait for
ProcessEvent := TJclDispatcherObject.Attach(ProcessInfo.hProcess);
- ProcessInfo.hProcess := 0; // ProcessEvent now "owns" the handle
SetLength(WaitEvents, 2);
// add the process first
WaitEvents[0] := ProcessEvent;
@@ -3017,14 +3016,16 @@
CloseHandle(ErrorPipeInfo.PipeWrite);
if ProcessInfo.hThread <> 0 then
CloseHandle(ProcessInfo.hThread);
- if ProcessInfo.hProcess <> 0 then
- begin
- TerminateProcess(ProcessInfo.hProcess, Cardinal(ABORT_EXIT_CODE));
- WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
- GetExitCodeProcess(ProcessInfo.hProcess, Result);
+
+ // always terminate process, especially useful when an exception occured
+ // in one of the texthandler
+ TerminateProcess(ProcessInfo.hProcess, Cardinal(ABORT_EXIT_CODE));
+ WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
+ GetExitCodeProcess(ProcessInfo.hProcess, Result);
+ if Assigned(ProcessEvent) then
+ ProcessEvent.Free // this calls CloseHandle(ProcessInfo.hProcess)
+ else
CloseHandle(ProcessInfo.hProcess);
- end;
- ProcessEvent.Free; // this calls CloseHandle(ProcessInfo.hProcess)
OutPipeInfo.Event.Free;
ErrorPipeInfo.Event.Free;
end;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ob...@us...> - 2012-05-14 12:15:36
|
Revision: 3793
http://jcl.svn.sourceforge.net/jcl/?rev=3793&view=rev
Author: obones
Date: 2012-05-14 12:15:29 +0000 (Mon, 14 May 2012)
Log Message:
-----------
Added priority for process spawned by the Execute function
Modified Paths:
--------------
trunk/jcl/source/common/JclSysUtils.pas
Modified: trunk/jcl/source/common/JclSysUtils.pas
===================================================================
--- trunk/jcl/source/common/JclSysUtils.pas 2012-05-10 19:34:22 UTC (rev 3792)
+++ trunk/jcl/source/common/JclSysUtils.pas 2012-05-14 12:15:29 UTC (rev 3793)
@@ -493,27 +493,28 @@
type
// e.g. TStrings.Append
TTextHandler = procedure(const Text: string) of object;
+ TJclProcessPriority = (ppIdle, ppNormal, ppHigh, ppRealTime, ppBelowNormal, ppAboveNormal);
const
ABORT_EXIT_CODE = {$IFDEF MSWINDOWS} ERROR_CANCELLED {$ELSE} 1223 {$ENDIF};
function Execute(const CommandLine: string; OutputLineCallback: TTextHandler; RawOutput: Boolean = False;
- AbortPtr: PBoolean = nil): Cardinal; overload;
+ AbortPtr: PBoolean = nil; ProcessPriority: TJclProcessPriority = ppNormal): Cardinal; overload;
function Execute(const CommandLine: string; AbortEvent: TJclEvent;
- OutputLineCallback: TTextHandler; RawOutput: Boolean = False): Cardinal; overload;
+ OutputLineCallback: TTextHandler; RawOutput: Boolean = False; ProcessPriority: TJclProcessPriority = ppNormal): Cardinal; overload;
function Execute(const CommandLine: string; var Output: string; RawOutput: Boolean = False;
- AbortPtr: PBoolean = nil): Cardinal; overload;
+ AbortPtr: PBoolean = nil; ProcessPriority: TJclProcessPriority = ppNormal): Cardinal; overload;
function Execute(const CommandLine: string; AbortEvent: TJclEvent;
- var Output: string; RawOutput: Boolean = False): Cardinal; overload;
+ var Output: string; RawOutput: Boolean = False; ProcessPriority: TJclProcessPriority = ppNormal): Cardinal; overload;
function Execute(const CommandLine: string; OutputLineCallback, ErrorLineCallback: TTextHandler;
- RawOutput: Boolean = False; RawError: Boolean = False; AbortPtr: PBoolean = nil): Cardinal; overload;
+ RawOutput: Boolean = False; RawError: Boolean = False; AbortPtr: PBoolean = nil; ProcessPriority: TJclProcessPriority = ppNormal): Cardinal; overload;
function Execute(const CommandLine: string; AbortEvent: TJclEvent;
- OutputLineCallback, ErrorLineCallback: TTextHandler; RawOutput: Boolean = False; RawError: Boolean = False): Cardinal; overload;
+ OutputLineCallback, ErrorLineCallback: TTextHandler; RawOutput: Boolean = False; RawError: Boolean = False; ProcessPriority: TJclProcessPriority = ppNormal): Cardinal; overload;
function Execute(const CommandLine: string; var Output, Error: string;
- RawOutput: Boolean = False; RawError: Boolean = False; AbortPtr: PBoolean = nil): Cardinal; overload;
+ RawOutput: Boolean = False; RawError: Boolean = False; AbortPtr: PBoolean = nil; ProcessPriority: TJclProcessPriority = ppNormal): Cardinal; overload;
function Execute(const CommandLine: string; AbortEvent: TJclEvent;
- var Output, Error: string; RawOutput: Boolean = False; RawError: Boolean = False): Cardinal; overload;
+ var Output, Error: string; RawOutput: Boolean = False; RawError: Boolean = False; ProcessPriority: TJclProcessPriority = ppNormal): Cardinal; overload;
type
{$HPPEMIT 'namespace Jclsysutils'}
@@ -2853,9 +2854,18 @@
Result := True;
end;
+const
+ BELOW_NORMAL_PRIORITY_CLASS = $00004000;
+ ABOVE_NORMAL_PRIORITY_CLASS = $00008000;
+
+ ProcessPriorities: array [TJclProcessPriority] of DWORD =
+ (IDLE_PRIORITY_CLASS, NORMAL_PRIORITY_CLASS, HIGH_PRIORITY_CLASS, REALTIME_PRIORITY_CLASS,
+ BELOW_NORMAL_PRIORITY_CLASS, ABOVE_NORMAL_PRIORITY_CLASS);
+
function InternalExecute(CommandLine: string; AbortPtr: PBoolean; AbortEvent: TJclEvent;
var Output: string; OutputLineCallback: TTextHandler; RawOutput: Boolean;
- MergeError: Boolean; var Error: string; ErrorLineCallback: TTextHandler; RawError: Boolean): Cardinal;
+ MergeError: Boolean; var Error: string; ErrorLineCallback: TTextHandler; RawError: Boolean;
+ ProcessPriority: TJclProcessPriority): Cardinal;
var
OutPipeInfo, ErrorPipeInfo: TPipeInfo;
Index: Cardinal;
@@ -2914,7 +2924,7 @@
ProcessInfo.dwProcessId := 0;
ProcessEvent := nil;
try
- if CreateProcess(nil, PChar(CommandLine), nil, nil, True, NORMAL_PRIORITY_CLASS,
+ if CreateProcess(nil, PChar(CommandLine), nil, nil, True, ProcessPriorities[ProcessPriority],
nil, nil, StartupInfo, ProcessInfo) then
begin
// init out and error events
@@ -3082,20 +3092,20 @@
That is, for RawOutput = False, lines not terminated by a line feed (#10) are deleted from Output. }
function Execute(const CommandLine: string; var Output: string; RawOutput: Boolean;
- AbortPtr: PBoolean): Cardinal;
+ AbortPtr: PBoolean; ProcessPriority: TJclProcessPriority): Cardinal;
var
Error: string;
begin
Error := '';
- Result := InternalExecute(CommandLine, AbortPtr, nil, Output, nil, RawOutput, True, Error, nil, False);
+ Result := InternalExecute(CommandLine, AbortPtr, nil, Output, nil, RawOutput, True, Error, nil, False, ProcessPriority);
end;
-function Execute(const CommandLine: string; AbortEvent: TJclEvent; var Output: string; RawOutput: Boolean): Cardinal;
+function Execute(const CommandLine: string; AbortEvent: TJclEvent; var Output: string; RawOutput: Boolean; ProcessPriority: TJclProcessPriority): Cardinal;
var
Error: string;
begin
Error := '';
- Result := InternalExecute(CommandLine, nil, AbortEvent, Output, nil, RawOutput, True, Error, nil, False);
+ Result := InternalExecute(CommandLine, nil, AbortEvent, Output, nil, RawOutput, True, Error, nil, False, ProcessPriority);
end;
{ TODO -cHelp :
@@ -3103,22 +3113,22 @@
OutputLineCallback called once per line of output. }
function Execute(const CommandLine: string; OutputLineCallback: TTextHandler; RawOutput: Boolean;
- AbortPtr: PBoolean): Cardinal;
+ AbortPtr: PBoolean; ProcessPriority: TJclProcessPriority): Cardinal;
var
Output, Error: string;
begin
Output := '';
Error := '';
- Result := InternalExecute(CommandLine, AbortPtr, nil, Output, OutputLineCallback, RawOutput, True, Error, nil, False);
+ Result := InternalExecute(CommandLine, AbortPtr, nil, Output, OutputLineCallback, RawOutput, True, Error, nil, False, ProcessPriority);
end;
-function Execute(const CommandLine: string; AbortEvent: TJclEvent; OutputLineCallback: TTextHandler; RawOutput: Boolean): Cardinal;
+function Execute(const CommandLine: string; AbortEvent: TJclEvent; OutputLineCallback: TTextHandler; RawOutput: Boolean; ProcessPriority: TJclProcessPriority): Cardinal;
var
Output, Error: string;
begin
Output := '';
Error := '';
- Result := InternalExecute(CommandLine, nil, AbortEvent, Output, OutputLineCallback, RawOutput, True, Error, nil, False);
+ Result := InternalExecute(CommandLine, nil, AbortEvent, Output, OutputLineCallback, RawOutput, True, Error, nil, False, ProcessPriority);
end;
{ TODO -cHelp :
@@ -3126,15 +3136,15 @@
That is, for RawOutput = False, lines not terminated by a line feed (#10) are deleted from Output. }
function Execute(const CommandLine: string; var Output, Error: string; RawOutput, RawError: Boolean;
- AbortPtr: PBoolean): Cardinal;
+ AbortPtr: PBoolean; ProcessPriority: TJclProcessPriority): Cardinal;
begin
- Result := InternalExecute(CommandLine, AbortPtr, nil, Output, nil, RawOutput, False, Error, nil, RawError);
+ Result := InternalExecute(CommandLine, AbortPtr, nil, Output, nil, RawOutput, False, Error, nil, RawError, ProcessPriority);
end;
function Execute(const CommandLine: string; AbortEvent: TJclEvent; var Output, Error: string;
- RawOutput, RawError: Boolean): Cardinal;
+ RawOutput, RawError: Boolean; ProcessPriority: TJclProcessPriority): Cardinal;
begin
- Result := InternalExecute(CommandLine, nil, AbortEvent, Output, nil, RawOutput, False, Error, nil, RawError);
+ Result := InternalExecute(CommandLine, nil, AbortEvent, Output, nil, RawOutput, False, Error, nil, RawError, ProcessPriority);
end;
{ TODO -cHelp :
@@ -3142,23 +3152,23 @@
OutputLineCallback called once per line of output. }
function Execute(const CommandLine: string; OutputLineCallback, ErrorLineCallback: TTextHandler;
- RawOutput, RawError: Boolean; AbortPtr: PBoolean): Cardinal;
+ RawOutput, RawError: Boolean; AbortPtr: PBoolean; ProcessPriority: TJclProcessPriority): Cardinal;
var
Output, Error: string;
begin
Output := '';
Error := '';
- Result := InternalExecute(CommandLine, AbortPtr, nil, Output, OutputLineCallback, RawOutput, False, Error, ErrorLineCallback, RawError);
+ Result := InternalExecute(CommandLine, AbortPtr, nil, Output, OutputLineCallback, RawOutput, False, Error, ErrorLineCallback, RawError, ProcessPriority);
end;
function Execute(const CommandLine: string; AbortEvent: TJclEvent; OutputLineCallback, ErrorLineCallback: TTextHandler;
- RawOutput, RawError: Boolean): Cardinal;
+ RawOutput, RawError: Boolean; ProcessPriority: TJclProcessPriority): Cardinal;
var
Output, Error: string;
begin
Output := '';
Error := '';
- Result := InternalExecute(CommandLine, nil, AbortEvent, Output, OutputLineCallback, RawOutput, False, Error, ErrorLineCallback, RawError);
+ Result := InternalExecute(CommandLine, nil, AbortEvent, Output, OutputLineCallback, RawOutput, False, Error, ErrorLineCallback, RawError, ProcessPriority);
end;
//=== { TJclCommandLineTool } ================================================
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ob...@us...> - 2012-05-15 10:16:27
|
Revision: 3794
http://jcl.svn.sourceforge.net/jcl/?rev=3794&view=rev
Author: obones
Date: 2012-05-15 10:16:16 +0000 (Tue, 15 May 2012)
Log Message:
-----------
Only terminate process it if the process actually started, this prevents eating up the last error value by calling those three functions with an invalid handle
Modified Paths:
--------------
trunk/jcl/source/common/JclSysUtils.pas
Modified: trunk/jcl/source/common/JclSysUtils.pas
===================================================================
--- trunk/jcl/source/common/JclSysUtils.pas 2012-05-14 12:15:29 UTC (rev 3793)
+++ trunk/jcl/source/common/JclSysUtils.pas 2012-05-15 10:16:16 UTC (rev 3794)
@@ -3029,12 +3029,19 @@
// always terminate process, especially useful when an exception occured
// in one of the texthandler
- TerminateProcess(ProcessInfo.hProcess, Cardinal(ABORT_EXIT_CODE));
- WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
- GetExitCodeProcess(ProcessInfo.hProcess, Result);
+ // but only do it if the process actually started, this prevents eating
+ // up the last error value by calling those three functions with an
+ // invalid handle
+ if ProcessInfo.hProcess <> 0 then
+ begin
+ TerminateProcess(ProcessInfo.hProcess, Cardinal(ABORT_EXIT_CODE));
+ WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
+ GetExitCodeProcess(ProcessInfo.hProcess, Result);
+ end;
+
if Assigned(ProcessEvent) then
ProcessEvent.Free // this calls CloseHandle(ProcessInfo.hProcess)
- else
+ else if ProcessInfo.hProcess <> 0 then
CloseHandle(ProcessInfo.hProcess);
OutPipeInfo.Event.Free;
ErrorPipeInfo.Event.Free;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ob...@us...> - 2012-07-20 13:42:20
|
Revision: 3808
http://jcl.svn.sourceforge.net/jcl/?rev=3808&view=rev
Author: obones
Date: 2012-07-20 13:42:11 +0000 (Fri, 20 Jul 2012)
Log Message:
-----------
Much better to do it in the except part so that it does not overwrite LastError when there is no exception
Modified Paths:
--------------
trunk/jcl/source/common/JclSysUtils.pas
Modified: trunk/jcl/source/common/JclSysUtils.pas
===================================================================
--- trunk/jcl/source/common/JclSysUtils.pas 2012-07-06 13:58:27 UTC (rev 3807)
+++ trunk/jcl/source/common/JclSysUtils.pas 2012-07-20 13:42:11 UTC (rev 3808)
@@ -2938,93 +2938,112 @@
if CreateProcess(nil, PChar(CommandLine), nil, nil, True, ProcessPriorities[ProcessPriority],
nil, nil, StartupInfo, ProcessInfo) then
begin
- // init out and error events
- CloseHandle(OutPipeInfo.PipeWrite);
- OutPipeInfo.PipeWrite := 0;
- if not MergeError then
- begin
- CloseHandle(ErrorPipeInfo.PipeWrite);
- ErrorPipeInfo.PipeWrite := 0;
- end;
- InternalAbort := False;
- if AbortPtr <> nil then
- AbortPtr^ := {$IFDEF FPC}Byte({$ENDIF}False{$IFDEF FPC}){$ENDIF}
- else
- AbortPtr := @InternalAbort;
- // init the array of events to wait for
- ProcessEvent := TJclDispatcherObject.Attach(ProcessInfo.hProcess);
- SetLength(WaitEvents, 2);
- // add the process first
- WaitEvents[0] := ProcessEvent;
- // add the output event
- WaitEvents[1] := OutPipeInfo.Event;
- // add the error event
- if not MergeError then
- begin
- SetLength(WaitEvents, 3);
- WaitEvents[2] := ErrorPipeInfo.Event;
- end;
- // add the abort event if any
- if AbortEvent <> nil then
- begin
- AbortEvent.ResetEvent;
- Index := Length(WaitEvents);
- SetLength(WaitEvents, Index + 1);
- WaitEvents[Index] := AbortEvent;
- end;
- // init the asynchronous reads
- ResetMemory(OutOverlapped, SizeOf(OutOverlapped));
- OutOverlapped.hEvent := OutPipeInfo.Event.Handle;
- InternalExecuteReadPipe(OutPipeInfo, OutOverlapped);
- if not MergeError then
- begin
- ResetMemory(ErrorOverlapped, SizeOf(ErrorOverlapped));
- ErrorOverlapped.hEvent := ErrorPipeInfo.Event.Handle;
- InternalExecuteReadPipe(ErrorPipeInfo, ErrorOverlapped);
- end;
- // event based loop
- while not {$IFDEF FPC}Boolean({$ENDIF}AbortPtr^{$IFDEF FPC}){$ENDIF} do
- begin
- Index := WaitAlertableForMultipleObjects(WaitEvents, False, INFINITE);
- if Index = WAIT_OBJECT_0 then
- // the subprocess has ended
- Break
- else
- if Index = (WAIT_OBJECT_0 + 1) then
+ try
+ // init out and error events
+ CloseHandle(OutPipeInfo.PipeWrite);
+ OutPipeInfo.PipeWrite := 0;
+ if not MergeError then
begin
- // event on output
- InternalExecuteHandlePipeEvent(OutPipeInfo, OutOverlapped);
- end
+ CloseHandle(ErrorPipeInfo.PipeWrite);
+ ErrorPipeInfo.PipeWrite := 0;
+ end;
+ InternalAbort := False;
+ if AbortPtr <> nil then
+ AbortPtr^ := {$IFDEF FPC}Byte({$ENDIF}False{$IFDEF FPC}){$ENDIF}
else
- if (Index = (WAIT_OBJECT_0 + 2)) and not MergeError then
+ AbortPtr := @InternalAbort;
+ // init the array of events to wait for
+ ProcessEvent := TJclDispatcherObject.Attach(ProcessInfo.hProcess);
+ SetLength(WaitEvents, 2);
+ // add the process first
+ WaitEvents[0] := ProcessEvent;
+ // add the output event
+ WaitEvents[1] := OutPipeInfo.Event;
+ // add the error event
+ if not MergeError then
begin
- // event on error
- InternalExecuteHandlePipeEvent(ErrorPipeInfo, ErrorOverlapped);
- end
- else
- if ((Index = (WAIT_OBJECT_0 + 2)) and MergeError) or
- ((Index = (WAIT_OBJECT_0 + 3)) and not MergeError) then
- // event on abort
- AbortPtr^ := {$IFDEF FPC}Byte({$ENDIF}True{$IFDEF FPC}){$ENDIF}
- else
- {$IFDEF DELPHI11_UP}
- RaiseLastOSError(Index);
- {$ELSE}
- RaiseLastOSError;
- {$ENDIF DELPHI11_UP}
+ SetLength(WaitEvents, 3);
+ WaitEvents[2] := ErrorPipeInfo.Event;
+ end;
+ // add the abort event if any
+ if AbortEvent <> nil then
+ begin
+ AbortEvent.ResetEvent;
+ Index := Length(WaitEvents);
+ SetLength(WaitEvents, Index + 1);
+ WaitEvents[Index] := AbortEvent;
+ end;
+ // init the asynchronous reads
+ ResetMemory(OutOverlapped, SizeOf(OutOverlapped));
+ OutOverlapped.hEvent := OutPipeInfo.Event.Handle;
+ InternalExecuteReadPipe(OutPipeInfo, OutOverlapped);
+ if not MergeError then
+ begin
+ ResetMemory(ErrorOverlapped, SizeOf(ErrorOverlapped));
+ ErrorOverlapped.hEvent := ErrorPipeInfo.Event.Handle;
+ InternalExecuteReadPipe(ErrorPipeInfo, ErrorOverlapped);
+ end;
+ // event based loop
+ while not {$IFDEF FPC}Boolean({$ENDIF}AbortPtr^{$IFDEF FPC}){$ENDIF} do
+ begin
+ Index := WaitAlertableForMultipleObjects(WaitEvents, False, INFINITE);
+ if Index = WAIT_OBJECT_0 then
+ // the subprocess has ended
+ Break
+ else
+ if Index = (WAIT_OBJECT_0 + 1) then
+ begin
+ // event on output
+ InternalExecuteHandlePipeEvent(OutPipeInfo, OutOverlapped);
+ end
+ else
+ if (Index = (WAIT_OBJECT_0 + 2)) and not MergeError then
+ begin
+ // event on error
+ InternalExecuteHandlePipeEvent(ErrorPipeInfo, ErrorOverlapped);
+ end
+ else
+ if ((Index = (WAIT_OBJECT_0 + 2)) and MergeError) or
+ ((Index = (WAIT_OBJECT_0 + 3)) and not MergeError) then
+ // event on abort
+ AbortPtr^ := {$IFDEF FPC}Byte({$ENDIF}True{$IFDEF FPC}){$ENDIF}
+ else
+ {$IFDEF DELPHI11_UP}
+ RaiseLastOSError(Index);
+ {$ELSE}
+ RaiseLastOSError;
+ {$ENDIF DELPHI11_UP}
+ end;
+ if {$IFDEF FPC}Boolean({$ENDIF}AbortPtr^{$IFDEF FPC}){$ENDIF} then
+ TerminateProcess(ProcessEvent.Handle, Cardinal(ABORT_EXIT_CODE));
+ if (ProcessEvent.WaitForever = wrSignaled) and not GetExitCodeProcess(ProcessEvent.Handle, Result) then
+ Result := $FFFFFFFF;
+ CloseHandle(ProcessInfo.hThread);
+ ProcessInfo.hThread := 0;
+ if OutPipeInfo.PipeRead <> 0 then
+ // read data remaining in output pipe
+ InternalExecuteFlushPipe(OutPipeinfo, OutOverlapped);
+ if not MergeError and (ErrorPipeInfo.PipeRead <> 0) then
+ // read data remaining in error pipe
+ InternalExecuteFlushPipe(ErrorPipeInfo, ErrorOverlapped);
+ except
+ // always terminate process in case of an exception.
+ // This is especially useful when an exception occured in one of
+ // the texthandler but only do it if the process actually started,
+ // this prevents eating up the last error value by calling those
+ // three functions with an invalid handle
+ // Note that we don't do it in the finally block because these
+ // calls would also then eat up the last error value which we tried
+ // to avoid in the first place
+ if ProcessInfo.hProcess <> 0 then
+ begin
+ TerminateProcess(ProcessInfo.hProcess, Cardinal(ABORT_EXIT_CODE));
+ WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
+ GetExitCodeProcess(ProcessInfo.hProcess, Result);
+ end;
+
+ raise;
end;
- if {$IFDEF FPC}Boolean({$ENDIF}AbortPtr^{$IFDEF FPC}){$ENDIF} then
- TerminateProcess(ProcessEvent.Handle, Cardinal(ABORT_EXIT_CODE));
- if (ProcessEvent.WaitForever = wrSignaled) and not GetExitCodeProcess(ProcessEvent.Handle, Result) then
- Result := $FFFFFFFF;
- CloseHandle(ProcessInfo.hThread);
- ProcessInfo.hThread := 0;
- if OutPipeInfo.PipeRead <> 0 then
- // read data remaining in output pipe
- InternalExecuteFlushPipe(OutPipeinfo, OutOverlapped);
- if not MergeError and (ErrorPipeInfo.PipeRead <> 0) then
- // read data remaining in error pipe
- InternalExecuteFlushPipe(ErrorPipeInfo, ErrorOverlapped);
end;
finally
if OutPipeInfo.PipeRead <> 0 then
@@ -3038,18 +3057,6 @@
if ProcessInfo.hThread <> 0 then
CloseHandle(ProcessInfo.hThread);
- // always terminate process, especially useful when an exception occured
- // in one of the texthandler
- // but only do it if the process actually started, this prevents eating
- // up the last error value by calling those three functions with an
- // invalid handle
- if ProcessInfo.hProcess <> 0 then
- begin
- TerminateProcess(ProcessInfo.hProcess, Cardinal(ABORT_EXIT_CODE));
- WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
- GetExitCodeProcess(ProcessInfo.hProcess, Result);
- end;
-
if Assigned(ProcessEvent) then
ProcessEvent.Free // this calls CloseHandle(ProcessInfo.hProcess)
else if ProcessInfo.hProcess <> 0 then
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ou...@us...> - 2012-08-13 13:00:51
|
Revision: 3817
http://jcl.svn.sourceforge.net/jcl/?rev=3817&view=rev
Author: outchy
Date: 2012-08-13 13:00:43 +0000 (Mon, 13 Aug 2012)
Log Message:
-----------
Mantis 5742: String to unsigned int conversion ?
Rename StrToCardinal to StrToUInt.
Modified Paths:
--------------
trunk/jcl/source/common/JclSysUtils.pas
Modified: trunk/jcl/source/common/JclSysUtils.pas
===================================================================
--- trunk/jcl/source/common/JclSysUtils.pas 2012-08-13 12:35:38 UTC (rev 3816)
+++ trunk/jcl/source/common/JclSysUtils.pas 2012-08-13 13:00:43 UTC (rev 3817)
@@ -597,9 +597,9 @@
function IntToBool(I: Integer): Boolean;
function BoolToInt(B: Boolean): Integer;
-function TryStrToCardinal(const Value: string; out Res: Cardinal): boolean;
-function StrToCardinalDef(const Value: string; const Default: Cardinal): Cardinal;
-function StrToCardinal(const Value: string): Cardinal;
+function TryStrToUInt(const Value: string; out Res: Cardinal): Boolean;
+function StrToUIntDef(const Value: string; const Default: Cardinal): Cardinal;
+function StrToUInt(const Value: string): Cardinal;
const
{$IFDEF MSWINDOWS}
@@ -3468,7 +3468,7 @@
Result := Ord(B);
end;
-function TryStrToCardinal(const Value: string; out Res: Cardinal): boolean;
+function TryStrToUInt(const Value: string; out Res: Cardinal): Boolean;
var i6: Int64;
begin
Result := false;
@@ -3479,15 +3479,15 @@
Res := i6;
end;
-function StrToCardinalDef(const Value: string; const Default: Cardinal): Cardinal;
+function StrToUIntDef(const Value: string; const Default: Cardinal): Cardinal;
begin
- if not TryStrToCardinal(Value, Result)
+ if not TryStrToUInt(Value, Result)
then Result := Default;
end;
-function StrToCardinal(const Value: string): Cardinal;
+function StrToUInt(const Value: string): Cardinal;
begin
- if not TryStrToCardinal(Value, Result)
+ if not TryStrToUInt(Value, Result)
then raise EConvertError.Create('"'+Value+'" is not within range of Cardinal data type');
end;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ob...@us...> - 2012-09-03 14:47:18
|
Revision: 3859
http://jcl.svn.sourceforge.net/jcl/?rev=3859&view=rev
Author: obones
Date: 2012-09-03 14:47:08 +0000 (Mon, 03 Sep 2012)
Log Message:
-----------
CreateNamedPipe returns INVALID_HANDLE_VALUE and not zero when there is a problem (see MSDN)
We must preserve LastError when doing our cleanup
Modified Paths:
--------------
trunk/jcl/source/common/JclSysUtils.pas
Modified: trunk/jcl/source/common/JclSysUtils.pas
===================================================================
--- trunk/jcl/source/common/JclSysUtils.pas 2012-09-03 10:25:41 UTC (rev 3858)
+++ trunk/jcl/source/common/JclSysUtils.pas 2012-09-03 14:47:08 UTC (rev 3859)
@@ -2846,7 +2846,7 @@
PipeReadHandle := CreateNamedPipe(PChar(PipeName), PIPE_ACCESS_INBOUND or FILE_FLAG_OVERLAPPED,
PIPE_TYPE_BYTE or PIPE_WAIT, 1, nSize, nSize, 120 * 1000, lpPipeAttributes);
- if PipeReadHandle = 0 then
+ if PipeReadHandle = INVALID_HANDLE_VALUE then
Exit;
PipeWriteHandle := CreateFile(PChar(PipeName), GENERIC_WRITE, 0, lpPipeAttributes, OPEN_EXISTING,
@@ -2889,6 +2889,7 @@
ProcessEvent: TJclDispatcherObject;
WaitEvents: array of TJclDispatcherObject;
InternalAbort: Boolean;
+ LastError: DWORD;
begin
// hack to pass a null reference to the parameter lpNumberOfBytesRead of ReadFile
Result := $FFFFFFFF;
@@ -3046,23 +3047,28 @@
end;
end;
finally
- if OutPipeInfo.PipeRead <> 0 then
- CloseHandle(OutPipeInfo.PipeRead);
- if OutPipeInfo.PipeWrite <> 0 then
- CloseHandle(OutPipeInfo.PipeWrite);
- if ErrorPipeInfo.PipeRead <> 0 then
- CloseHandle(ErrorPipeInfo.PipeRead);
- if ErrorPipeInfo.PipeWrite <> 0 then
- CloseHandle(ErrorPipeInfo.PipeWrite);
- if ProcessInfo.hThread <> 0 then
- CloseHandle(ProcessInfo.hThread);
+ LastError := GetLastError;
+ try
+ if OutPipeInfo.PipeRead <> 0 then
+ CloseHandle(OutPipeInfo.PipeRead);
+ if OutPipeInfo.PipeWrite <> 0 then
+ CloseHandle(OutPipeInfo.PipeWrite);
+ if ErrorPipeInfo.PipeRead <> 0 then
+ CloseHandle(ErrorPipeInfo.PipeRead);
+ if ErrorPipeInfo.PipeWrite <> 0 then
+ CloseHandle(ErrorPipeInfo.PipeWrite);
+ if ProcessInfo.hThread <> 0 then
+ CloseHandle(ProcessInfo.hThread);
- if Assigned(ProcessEvent) then
- ProcessEvent.Free // this calls CloseHandle(ProcessInfo.hProcess)
- else if ProcessInfo.hProcess <> 0 then
- CloseHandle(ProcessInfo.hProcess);
- OutPipeInfo.Event.Free;
- ErrorPipeInfo.Event.Free;
+ if Assigned(ProcessEvent) then
+ ProcessEvent.Free // this calls CloseHandle(ProcessInfo.hProcess)
+ else if ProcessInfo.hProcess <> 0 then
+ CloseHandle(ProcessInfo.hProcess);
+ OutPipeInfo.Event.Free;
+ ErrorPipeInfo.Event.Free;
+ finally
+ SetLastError(LastError);
+ end;
end;
{$ENDIF MSWINDOWS}
{$IFDEF UNIX}
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ob...@us...> - 2012-09-03 14:52:17
|
Revision: 3860
http://jcl.svn.sourceforge.net/jcl/?rev=3860&view=rev
Author: obones
Date: 2012-09-03 14:52:06 +0000 (Mon, 03 Sep 2012)
Log Message:
-----------
In some (not so) rare instances there is a race condition where the counter is the same for two threads at the same time. This makes the CreateNamedPipe call fail because of the limit set to 1 in the call.
So, to be sure the call succeeds, we put both the process and thread id in the name of the pipe.
This was found to happen while simply starting 7 instances of the same exe file in parallel
Modified Paths:
--------------
trunk/jcl/source/common/JclSysUtils.pas
Modified: trunk/jcl/source/common/JclSysUtils.pas
===================================================================
--- trunk/jcl/source/common/JclSysUtils.pas 2012-09-03 14:47:08 UTC (rev 3859)
+++ trunk/jcl/source/common/JclSysUtils.pas 2012-09-03 14:52:06 UTC (rev 3860)
@@ -2842,7 +2842,15 @@
nSize := 4096;
InterlockedIncrement(AsyncPipeCounter);
- PipeName := Format('\\.\Pipe\AsyncAnonPipe.%.8x.%.8x', [GetCurrentProcessId, AsyncPipeCounter]);
+ // In some (not so) rare instances there is a race condition
+ // where the counter is the same for two threads at the same
+ // time. This makes the CreateNamedPipe call below fail
+ // because of the limit set to 1 in the call.
+ // So, to be sure this call succeeds, we put both the process
+ // and thread id in the name of the pipe.
+ // This was found to happen while simply starting 7 instances
+ // of the same exe file in parallel.
+ PipeName := Format('\\.\Pipe\AsyncAnonPipe.%.8x.%.8x.%.8x', [GetCurrentProcessId, GetCurrentThreadId, AsyncPipeCounter]);
PipeReadHandle := CreateNamedPipe(PChar(PipeName), PIPE_ACCESS_INBOUND or FILE_FLAG_OVERLAPPED,
PIPE_TYPE_BYTE or PIPE_WAIT, 1, nSize, nSize, 120 * 1000, lpPipeAttributes);
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
Thanks for helping keep SourceForge clean.
X