How to avoid app freeze in memory execute function?
After I send resource to memory and when I run this code, my exe in memory runs successfully, but UI form will freeze until process close.
Here's my code:
unit pe;
interface
uses Windows;
//type
// TByteArray = array of Byte;
Function MemoryExecute(Buffer :Pointer;Parameters: String; Visible: Boolean): TProcessInformation;
implementation
Function MemoryExecute(Buffer :Pointer;Parameters: String; Visible: Boolean): TProcessInformation;
type
HANDLE = THandle;
PVOID = Pointer;
LPVOID = Pointer;
SIZE_T = Cardinal;
ULONG_PTR = Cardinal;
NTSTATUS = LongInt;
LONG_PTR = Integer;
PImageSectionHeaders = ^TImageSectionHeaders;
TImageSectionHeaders = Array [0..95] Of TImageSectionHeader;
Var
ZwUnmapViewOfSection :Function(ProcessHandle: THANDLE; BaseAddress: Pointer): LongInt; stdcall;
ProcessInfo :TProcessInformation;
StartupInfo :TStartupInfo;
Context :TContext;
BaseAddress :Pointer;
BytesRead :DWORD;
BytesWritten :DWORD;
I :ULONG;
OldProtect :ULONG;
NTHeaders :PImageNTHeaders;
Sections :PImageSectionHeaders;
Success :Boolean;
ProcessName :string;
Function ImageFirstSection(NTHeader: PImageNTHeaders): PImageSectionHeader;
Begin
Result := PImageSectionheader( ULONG_PTR(#NTheader.OptionalHeader) +
NTHeader.FileHeader.SizeOfOptionalHeader);
End;
Function Protect(Characteristics: ULONG): ULONG;
Const
Mapping :Array[0..7] Of ULONG = (
PAGE_NOACCESS,
PAGE_EXECUTE,
PAGE_READONLY,
PAGE_EXECUTE_READ,
PAGE_READWRITE,
PAGE_EXECUTE_READWRITE,
PAGE_READWRITE,
PAGE_EXECUTE_READWRITE );
Begin
Result := Mapping[ Characteristics SHR 29 ];
End;
Begin
#ZwUnmapViewOfSection := GetProcAddress(LoadLibrary('ntdll.dll'), 'ZwUnmapViewOfSection');
ProcessName := ParamStr(0);
FillChar(ProcessInfo, SizeOf(TProcessInformation), 0);
FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
StartupInfo.cb := SizeOf(TStartupInfo);
StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
if Visible Then
StartupInfo.wShowWindow := SW_NORMAL
else
StartupInfo.wShowWindow := SW_Hide;
If (CreateProcess(PChar(ProcessName), PChar(Parameters), NIL, NIL,
False, CREATE_SUSPENDED, NIL, NIL, StartupInfo, ProcessInfo)) Then
Begin
Success := True;
Result := ProcessInfo;
Try
Context.ContextFlags := CONTEXT_INTEGER;
If (GetThreadContext(ProcessInfo.hThread, Context) And
(ReadProcessMemory(ProcessInfo.hProcess, Pointer(Context.Ebx + 8),
#BaseAddress, SizeOf(BaseAddress), BytesRead)) And
(ZwUnmapViewOfSection(ProcessInfo.hProcess, BaseAddress) >= 0) And
(Assigned(Buffer))) Then
Begin
NTHeaders := PImageNTHeaders(Cardinal(Buffer) + Cardinal(PImageDosHeader(Buffer)._lfanew));
BaseAddress := VirtualAllocEx(ProcessInfo.hProcess,
Pointer(NTHeaders.OptionalHeader.ImageBase),
NTHeaders.OptionalHeader.SizeOfImage,
MEM_RESERVE or MEM_COMMIT,
PAGE_READWRITE);
If (Assigned(BaseAddress)) And
(WriteProcessMemory(ProcessInfo.hProcess, BaseAddress, Buffer,
NTHeaders.OptionalHeader.SizeOfHeaders,
BytesWritten)) Then
Begin
Sections := PImageSectionHeaders(ImageFirstSection(NTHeaders));
For I := 0 To NTHeaders.FileHeader.NumberOfSections -1 Do
If (WriteProcessMemory(ProcessInfo.hProcess,
Pointer(Cardinal(BaseAddress) +
Sections[I].VirtualAddress),
Pointer(Cardinal(Buffer) +
Sections[I].PointerToRawData),
Sections[I].SizeOfRawData, BytesWritten)) Then
VirtualProtectEx(ProcessInfo.hProcess,
Pointer(Cardinal(BaseAddress) +
Sections[I].VirtualAddress),
Sections[I].Misc.VirtualSize,
Protect(Sections[I].Characteristics),
OldProtect);
If (WriteProcessMemory(ProcessInfo.hProcess,
Pointer(Context.Ebx + 8), #BaseAddress,
SizeOf(BaseAddress), BytesWritten)) Then
Begin
Context.EAX := ULONG(BaseAddress) +
NTHeaders.OptionalHeader.AddressOfEntryPoint;
Success := SetThreadContext(ProcessInfo.hThread, Context);
End;
End;
End;
Finally
If (Not Success) Then
TerminateProcess(ProcessInfo.hProcess, 0)
else
ResumeThread(ProcessInfo.hThread);
WaitForSingleObject(ProcessInfo.hProcess,INFINITE) ;
// GetExitCodeProcess(ProcessInfo.hProcess, Result);
End;
End;
End;
end.
Your code freezes because it is calling WaitForSingleObject() to wait for the spawned process to exit, and while it is waiting it is not pumping the calling thread's message queue for new messages. To avoid that, you have three choices:
stop waiting altogether.
stop calling this code in your main thread. Move it to a worker thread.
call WaitForSingleObject() with a non-INFINITE timeout in a loop that pumps the message queue periodically. If you replace WaitForSingleObject() with MsgWaitForMultipleObjects(), it can tell you when new messages are waiting, so you don't need to pump the queue when there is nothing to process.
Personally, I would opt for #1, especially since the function returns a TProcessInformation describing the spawned process, so let the caller decide what to do with the process. If the caller wants to wait, it will have the process's handles to do so. If the caller does not want to wait, it does not have to.
Related
I'm new to Delphi, and have developed a small GUI application that runs innounp (which disassembles Inno setup installers) with selected parameters and captures the output into Memo.
I used this procedure (from here)
procedure RunProcessAndCaptureOutput(const CmdLine: string; Memo: TMemo; HideLinesCount: Integer = 0);
var
SecAttr: TSecurityAttributes;
PipeR, PipeW: THandle;
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
Buffer: packed array[0..4096-1] of AnsiChar;
Count: Cardinal;
S, Leftover: AnsiString;
i, P: Cardinal;
C: AnsiChar;
begin
SecAttr.nLength:=SizeOf(SecAttr);
SecAttr.lpSecurityDescriptor:=nil;
SecAttr.bInheritHandle:=True;
if not CreatePipe(PipeR, PipeW, #SecAttr, 0) then
raise Exception.Create('CreatePipe: '+SysErrorMessage(GetLastError));
SetHandleInformation(PipeR, HANDLE_FLAG_INHERIT, 0);
FillChar(StartupInfo, SizeOf(StartupInfo), 0);
StartupInfo.cb:=SizeOf(StartupInfo);
StartupInfo.dwFlags:=STARTF_USESTDHANDLES;
StartupInfo.hStdOutput:=PipeW;
StartupInfo.hStdError:=PipeW;
FillChar(ProcessInfo, SizeOf(ProcessInfo), 0);
if not CreateProcess(nil, PChar(CmdLine), nil, nil, True, CREATE_NO_WINDOW, nil, nil, StartupInfo, ProcessInfo) then
raise Exception.Create('CreateProcess: '+SysErrorMessage(GetLastError));
CloseHandle(ProcessInfo.hProcess);
CloseHandle(ProcessInfo.hThread);
CloseHandle(PipeW);
Leftover:='';
while ReadFile(PipeR, Buffer[0], SizeOf(Buffer)-1, Count, nil) and (Count > 0) do
begin
Buffer[Count]:=#0;
i:=0;
P:=0;
while i < Count do
begin
C:=Buffer[i];
if C in [#10, #13] then
begin
if HideLinesCount > 0 then
Dec(HideLinesCount)
else
begin
Buffer[i]:=#0;
S:=Leftover+AnsiString(PAnsiChar(#Buffer[P]));
OemToCharBuffA(#S[1], #S[1], Length(S));
Memo.Lines.Add(string(S));
end;
Leftover:='';
case C of
#10: if Buffer[i+1] = #13 then Inc(i);
#13: if Buffer[i+1] = #10 then Inc(i);
end;
P:=i+1;
end;
Inc(i);
end;
Leftover:=AnsiString(PAnsiChar(#Buffer[P]));
Application.ProcessMessages;
end;
if (Leftover <> '') and (HideLinesCount <= 0) then
begin
OemToCharBuffA(#Leftover[1], #Leftover[1], Length(Leftover));
Memo.Lines.Add(string(Leftover));
end;
CloseHandle(PipeR);
end;
It seems to be working (the innounp program is running, and the output appears inside the Memo) but after extracting one file the program displays an error "access denied" and does not continue to extract.
Can anyone help me understand why?
In theory connection attempt should terminate after 5 seconds. However in practice I still get infinite timeout. Is there any way to terminate connection from outside. For example I could use timer and then execute proper function to abort. Another nasty workaround would be fire thread and kill it with TerminateThread function.
function DownloadFile(URL, {User, Pass,} FileName: string): Boolean;
const
BufferSize = 1024;
var
hSession, hURL: HInternet;
Buffer: array[1..BufferSize] of Byte;
BufferLen,Connect_timeout: DWORD;
F: File;
User,Pass:string;
begin
User:='';
Pass:='';
Result := False;
hSession := InternetOpen('', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0) ;
Connect_timeout := 5000 ;
InternetSetOption(hSession, INTERNET_OPTION_CONNECT_TIMEOUT, Pointer(#Connect_timeout), sizeof(Connect_timeout));
// Establish the secure connection
InternetConnect (
hSession,
PChar(URL),
INTERNET_DEFAULT_HTTPS_PORT,
PChar(User),
PChar(Pass),
INTERNET_SERVICE_HTTP,
0,
0
);
try
hURL := InternetOpenURL(hSession, PChar(URL), nil, 0, 0, 0) ;
try
AssignFile(f, FileName);
Rewrite(f,1);
try
repeat
InternetReadFile(hURL, #Buffer, SizeOf(Buffer), BufferLen) ;
BlockWrite(f, Buffer, BufferLen)
until BufferLen = 0;
finally
CloseFile(f) ;
Result := True;
end;
finally
InternetCloseHandle(hURL)
end
finally
InternetCloseHandle(hSession)
end;
end;
How can I get Delphi to pass a string to the input pipe to a CMD process. I am able to get an error pipe and output pipe functioning properly, unfortunately not the input pipe. The code I am using is taken from an online tutorial for piping. There were several errors in the original code causing problems when it was compiled. They have been fixed but I am left with problems when trying to pass input still.
Here is the code in the Form.Create event. I also have included the WritePipe and ReadPipe methods. WritePipe does not work, ReadPipe does work. Both WriteFile and ReadFile in the Pipe methods return a successful message, only the ReadPipe actually works however.
var
DosApp: String;
DosSize: Integer;
Security : TSecurityAttributes;
start : TStartUpInfo;
byteswritten: DWord;
WriteString : ansistring;
begin
CommandText.Clear;
// get COMSPEC variable, this is the path of the command-interpreter
SetLength(Dosapp, 255);
DosSize := GetEnvironmentVariable('COMSPEC', #DosApp[1], 255);
SetLength(Dosapp, DosSize);
// create pipes
With Security do
begin
nlength := SizeOf(TSecurityAttributes) ;
binherithandle := true;
lpsecuritydescriptor := nil;
end;
CreatePipe(InputPipeRead, InputPipeWrite, #Security, 0);
CreatePipe(OutputPipeRead, OutputPipeWrite, #Security, 0);
CreatePipe(ErrorPipeRead, ErrorPipeWrite, #Security, 0);
// start command-interpreter
FillChar(Start,Sizeof(Start),#0) ;
//start.hStdInput := InputPipeRead;
start.hStdOutput := OutputPipeWrite;
start.hStdError := ErrorPipeWrite;
start.dwFlags := STARTF_USESTDHANDLES + STARTF_USESHOWWINDOW;
start.wShowWindow := SW_Show;//SW_HIDE;
start.cb := SizeOf(start) ;
if CreateProcess('', PChar(DosApp), #Security, #Security, true,
CREATE_NEW_CONSOLE or SYNCHRONIZE, // CREATE_NO_WINDOW,
nil, nil, start, ProcessInfo) then
begin
MyThread := MainUnit.monitor.Create; // start monitor thread
MyThread.Priority := tpHigher;
end;
Button1.Enabled := true;
cmdcount := 1;
end;
Write Pipe:
procedure WritePipeOut(OutputPipe: THandle; InString: PWideChar);
// writes Instring to the pipe handle described by OutputPipe
var
count : integer;
byteswritten: DWord;
outputstring : PAnsiChar;
TextBuffer: array[1..32767] of AnsiChar;// char;
TextString: String;
begin
// most console programs require CR/LF after their input.
InString := PWideChar(InString + #13#10);
WriteFile(InputPipeWrite, InString[1], Length(InString), byteswritten, nil);
end;
Read Pipe:
function ReadPipeInput(InputPipe: THandle; var BytesRem: Integer): String;
{
reads console output from InputPipe. Returns the input in function
result. Returns bytes of remaining information to BytesRem
}
var
TextBuffer: array[1..32767] of AnsiChar;// char;
TextString: String;
BytesRead: Cardinal;
PipeSize: Integer;
begin
Result := '';
PipeSize := length(TextBuffer);
// check if there is something to read in pipe
PeekNamedPipe(InputPipe, nil, PipeSize, #BytesRead, #PipeSize, #BytesRem);
if bytesread > 0 then
begin
ReadFile(InputPipe, TextBuffer, pipesize, bytesread, nil);
// a requirement for Windows OS system components
OemToChar(#TextBuffer, #TextBuffer);
TextString := String(TextBuffer);
SetLength(TextString, BytesRead);
Result := TextString;
end;
end;
Further note; this is for use with the Java Debugger, which requires input in stages and so I do not believe there is any alternative method other than manipulating input directly to the JDB.
Any help is much appreciated!
1) You should pass InputPipeRead as hStdInput into CreateProcess: uncomment your line start.hStdInput := InputPipeRead;
2) The WritePipeOut function has two errors: it writes a Unicode (UTF-16LE) string into a pipe, and it skips the first character (since it writes a memory area beginning at InString[1]). Instead of WriteFile(InputPipeWrite, InString[1], Length(InString),... you should write something like:
var AnsiBuf: AnsiString;
...
AnsiBuf := String(InString) + #13#10;
Write(InputPipeWrite, AnsiBuf[1], Length(AnsiBuf), byteswritten, nil);
I am monitoring in separate thread application configuration file, which in some cases may be INI in another XML or another.
Code of thread monitoring directory (in Delphi) is something like this:
procedure TWatcherThread.Execute;
type
PFileNotifyInformation = ^TFileNotifyInformation;
TFileNotifyInformation = record
NextEntryOffset: DWORD;
Action: DWORD;
FileNameLength: DWORD;
FileName: WideChar;
end;
const
BufferLength = 65536;
var
Filter, BytesRead: DWORD;
InfoPointer: PFileNotifyInformation;
Offset, NextOffset: DWORD;
Buffer: array[0..BufferLength - 1] of byte;
Overlap: TOverlapped;
Events: array[0..1] of THandle;
WaitResult: DWORD;
FileName, s: string;
begin
if fDirHandle <> INVALID_HANDLE_VALUE then begin
Filter := FILE_NOTIFY_CHANGE_LAST_WRITE;
FillChar(Overlap, SizeOf(TOverlapped), 0);
Overlap.hEvent := fChangeHandle;
Events[0] := fChangeHandle;
Events[1] := fShutdownHandle;
while not Terminated do begin
FillChar(Buffer,SizeOf(Buffer),0);
if ReadDirectoryChangesW (fDirHandle, #Buffer[0], BufferLength, TRUE,
Filter, #BytesRead, #Overlap, nil)
then begin
WaitResult := WaitForMultipleObjects(2, #Events[0], FALSE, INFINITE);
if WaitResult = WAIT_OBJECT_0 then begin
InfoPointer := #Buffer[0];
Offset := 0;
repeat
NextOffset := InfoPointer.NextEntryOffset;
FileName := WideCharToString(#InfoPointer.FileName);
if (InfoPointer.Action = FILE_ACTION_MODIFIED) and (CompareText(FileName, 'MyConfig.ini') = 0) then begin //read changes in config or INI file
// Do Action.. refresh runtime flags
end;
PByte(InfoPointer) := PByte(DWORD(InfoPointer) + NextOffset);
Offset := Offset + NextOffset;
until NextOffset = 0;
end;
end;
end;
end;
end;
Why it signals at least 2 times and how to get correct signal when some flag in config file was changed and was saved?
Raymond Chen explained this nicely on his blog: http://blogs.msdn.com/b/oldnewthing/archive/2014/05/07/10523172.aspx
In short "Because multiple things were modified."
I have bat-file, that make some operations. How to run this file from Delphi and wait, until it stops.
Something like that:
procedure TForm1.Button1Click(Sender: TObject);
begin
//Starting bat-file
bla-bla-bla
showmessage('Done');
end;
This executes the given command line and waits for the program started by the command line to exit. Returns true if the program returns a zero exit code and false if the program doesn't start or returns a non-zero error code.
function ExecAndWait(const CommandLine: string) : Boolean;
var
StartupInfo: Windows.TStartupInfo; // start-up info passed to process
ProcessInfo: Windows.TProcessInformation; // info about the process
ProcessExitCode: Windows.DWord; // process's exit code
begin
// Set default error result
Result := False;
// Initialise startup info structure to 0, and record length
FillChar(StartupInfo, SizeOf(StartupInfo), 0);
StartupInfo.cb := SizeOf(StartupInfo);
// Execute application commandline
if Windows.CreateProcess(nil, PChar(CommandLine),
nil, nil, False, 0, nil, nil,
StartupInfo, ProcessInfo) then
begin
try
// Now wait for application to complete
if Windows.WaitForSingleObject(ProcessInfo.hProcess, INFINITE)
= WAIT_OBJECT_0 then
// It's completed - get its exit code
if Windows.GetExitCodeProcess(ProcessInfo.hProcess,
ProcessExitCode) then
// Check exit code is zero => successful completion
if ProcessExitCode = 0 then
Result := True;
finally
// Tidy up
Windows.CloseHandle(ProcessInfo.hProcess);
Windows.CloseHandle(ProcessInfo.hThread);
end;
end;
end;
From: http://www.delphidabbler.com/codesnip?action=named&showsrc=1&routines=ExecAndWait
Here is some code and example - under Windows 7 works fine and is invisible
(funcion ExeAndWait is borrowed).
function ExeAndWait(ExeNameAndParams: string; ncmdShow: Integer = SW_SHOWNORMAL): Integer;
var
StartupInfo: TStartupInfo;
ProcessInformation: TProcessInformation;
Res: Bool;
lpExitCode: DWORD;
begin
with StartupInfo do //you can play with this structure
begin
cb := SizeOf(TStartupInfo);
lpReserved := nil;
lpDesktop := nil;
lpTitle := nil;
dwFlags := STARTF_USESHOWWINDOW;
wShowWindow := ncmdShow;
cbReserved2 := 0;
lpReserved2 := nil;
end;
Res := CreateProcess(nil, PChar(ExeNameAndParams), nil, nil, True,
CREATE_DEFAULT_ERROR_MODE
or NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInformation);
while True do
begin
GetExitCodeProcess(ProcessInformation.hProcess, lpExitCode);
if lpExitCode <> STILL_ACTIVE then
Break;
Application.ProcessMessages;
end;
Result := Integer(lpExitCode);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ExeAndWait(ExtractFilePath(Application.ExeName) + 'test.bat', SW_HIDE);
ShowMessage('Done!');
end;
PS. If you like you can build batch file at runtime using TStringList class.