SCARD_F_INTERNAL_ERROR result from SCardGetStatusChange - delphi

I'm developing application that is using Mifare Classic 1K card and HID Omnikey 5421 (successor of 5321). I using thread to detect card remove/insert.
Delphi code (thread method):
function CardWatcherThread(PContext: Pointer): integer;
var
RetVar : cardinal;
RContext : cardinal;
RStates : array[0..0] of SCARD_READERSTATEA;
begin
try
RContext := Cardinal(PContext^);
FillChar(RStates,SizeOf(RStates),#0);
RStates[0].szReader := SelectedReader;
RStates[0].pvUserData := nil;
RStates[0].dwCurrentState := SCARD_STATE_UNAWARE;
while ReaderOpen and (not Application.Terminated) do begin
RetVar := SCardGetStatusChange(RContext, MAX_WAIT_TIME_SCARDSTATUSCHANGE, #RStates, 1);
RStates[0].dwCurrentState := RStates[0].dwEventState;
ActReaderState := RStates[0].dwEventState;
// Avoid sedning error about timemout if MAX_WAIT_TIME_SCARDSTATUSCHANGE is not infinite
if (RetVar <> SCARD_E_TIMEOUT) or (MAX_WAIT_TIME_SCARDSTATUSCHANGE = -1) then begin
SendMessage(NotifyHandle, WM_CARDSTATE, RetVar, 0);
end;
end;
finally
Result := 0;
end;
end;
I'm using SendMessage to notify my Smart Card class where I'm detecting proper state. Also I automatically connect and read data from smart card when I detect card insertion.
My application is working correctly for most of the time, but sometimes for e.g. once in the 10000 of card insertion I'm getting SCARD_F_INTERNAL_ERROR from SCardGetStatusChange. When this happen SCardGetStatusChange is starting to result only SCARD_F_INTERNAL_ERROR all the time. When I detected this situation I tried to SCardCancel and SCardReleaseContext, end thread and establish new context and create new watcher thread with this new context but this is not helping because SCardGetStatusChange was continue to returning SCARD_F_INTERNAL_ERROR. Only when I close application and run again problem disappears.
It's happening randomly for me, I can't reproduce it using some known scenario. In PC can be more readers, but I'm establishing connection only to Omnikey 5421.
Someone met with this problem?

It's hard to say what goes wrong but I have few remarks about your code, hope they help...
you should check the return value of the SCardGetStatusChange as the first thing and if it is SCARD_E_TIMEOUT then just skip all the processing and start next cycle;
instead of just RStates[0].dwCurrentState := RStates[0].dwEventState; you also have to clear out the SCARD_STATE_CHANGED bit from the state (that is, if the state actually changed);
it is my understanding that the resource manager context might become invalid, so before calling SCardGetStatusChange use SCardIsValidContext to make sure you still have good context, if not acquire new one;
So try something like this (this is typed to the browser, so untestead and probably wont compile as is):
function CardWatcherThread(PContext: Pointer): integer;
var
RetVar : cardinal;
RContext : cardinal;
RStates : array[0..0] of SCARD_READERSTATEA;
begin
try
RContext := Cardinal(PContext^);
FillChar(RStates,SizeOf(RStates),#0);
RStates[0].szReader := SelectedReader;
RStates[0].pvUserData := nil;
RStates[0].dwCurrentState := SCARD_STATE_UNAWARE;
while ReaderOpen and (not Application.Terminated) do begin
if(SCardIsValidContext(RContext) <> SCARD_S_SUCCESS)then begin
RetVal := SCardEstablishContext(...);
end;
RetVar := SCardGetStatusChange(RContext, MAX_WAIT_TIME_SCARDSTATUSCHANGE, #RStates, 1);
case RetVal of
SCARD_E_TIMEOUT:;
SCARD_S_SUCCESS: begin
if((RStates[0].dwEventState and SCARD_STATE_CHANGED) <> 0)then begin
RStates[0].dwCurrentState := RStates[0].dwEventState xor SCARD_STATE_CHANGED;
// reader's state changed, do something
end;
end;
end;
end;
finally
Result := 0;
end;
end;

Related

No sound using Delphi and DirectX on Windows 10

I've a problem with using DirectX (DirectSound) on Windows 10. I'me changing some legacy code that used DirectX (DirectX 9 I think) and run on Windows XP.
Everything is still working great on Windows XP but I can't get a sound on Windows 10.
The application uses these files: DXUTIL.PAS (Original ObjectPascal conversion made by: Boris V.), lzexpand.pas (Author: Vadim Bodrov) and DirectSound.pas (DirectX 9.0 Delphi / FreePascal adaptation by Alexey Barkovoy).
procedure TForm1.Button1Click(Sender: TObject);
var
sndgwait : PSound;
begin
InitSB(Handle);
LoadWave(sndgwait, 'D:\game\EXP01.wav', 1);
StartSound(sndgwait, false);
end;
function LoadWave(var Sound: PSound; fn : string; conc : integer) : boolean;
var
cbData, cbdata1 : DWORD;
pd1 : pointer;
hfile : longint;
vreopenbuff : TOFStruct;
begin
hfile := LZOpenFile(PAnsiChar(fn), vreopenbuff, OF_READ);
if hfile < 0 then begin result := false; exit; end;
cbdata := LZSeek(hfile, 0, 2); // file size
LZSeek(hfile, 0, 0); //back to the start of the wav
getmem(pd1, cbdata);
LZRead(hfile, pd1, cbdata);
LZClose(hfile);
if conc < 1 then conc := 1;
result := ParseWaveData(Sound, conc, cbdata, pd1);
end;
function ParseWaveData(var Sound : PSound; conc : integer; cbdata : dword; pd1 : pointer) : boolean;
var
pWaveHeader: PWAVEFORMATEX;
pDSB: IDirectSoundBuffer;
dsBD: TDSBUFFERDESC;
rr : longint;
begin
if lpDS = nil then begin
result := false;
exit;
end;
Sound := PSNDOBJ(LocalAlloc(LPTR, SizeOf(TSNDOBJ) + (conc-1) * SizeOf(IDirectSoundBuffer)));
Sound^.iAlloc := conc;
Sound^.cbWaveSize := 0;
Sound^.pbWaveData := nil;
pwaveHeader := nil;
Sound^.pbData := pd1;
Sound^.cbSize := cbdata;
if DSParseWaveResource(pd1, pWaveHeader, Sound^.pbWaveData, Sound^.cbWaveSize) then begin
ZeroMemory(#dsBD, SizeOf(dsBD));
dsBD.dwSize := SizeOf(dsBD);
dsBD.dwFlags := DSBCAPS_STATIC or DSBCAPS_GETCURRENTPOSITION2 or DSBCAPS_CTRLFREQUENCY orDSBCAPS_CTRLPAN or DSBCAPS_CTRLVOLUME;//DSBCAPS_CTRLDEFAULT or
dsBD.lpwfxFormat := pWaveHeader;
dsBD.dwBufferBytes := Sound^.cbWaveSize;
if lpDS.CreateSoundBuffer(dsBD, pDSB, nil) = DS_OK then begin
if not DSFillSoundBuffer(pDSB, Sound^.pbWaveData, dsBD.dwBufferBytes) then begin
pDSB._Release;
pDSB := nil;
end;
Sound^.Buffers[0] := pDSB;
for rr := 1 to conc - 1 do begin
lpDS.DuplicateSoundBuffer(Sound^.Buffers[0], Sound^.Buffers[rr]);
end;
end else begin
pDSB := nil;
SndObjDestroy(Sound);
Sound := nil;
end;
end;
Result := Sound <> nil;
end;
function StartSound(Sound: PSound; Loop: boolean = false; waitforend: boolean = false): boolean;
begin
if Loop then
StartSound := SndObjPlay(Sound, DSBPLAY_LOOPING)
else
StartSound := SndObjPlay(Sound, 0);
if waitforend and not loop then
while SoundPlaying(Sound) do Application.ProcessMessages;
end;
function SndObjPlay(pSO: PSNDOBJ; dwPlayFlags: DWORD): Boolean;
var
pDSB: IDirectSoundBuffer;
begin
Result := FALSE;
if pSO = nil then
begin
exit;
end;
if ((dwPlayFlags and DSBPLAY_LOOPING) = 0) or (pSO^.iAlloc = 1) then
begin
pDSB := SndObjGetFreeBuffer(pSO);
if (pDSB <> nil) then
Result := SUCCEEDED(pDSB.Play(0, 0, dwPlayFlags));
end else
Result:= FALSE;
end;
All values in ParseWaveData call are correct I think (no nil values).
I'm not gething any errors. Just there is no sound.
What can be a problem here?
Or are there other ways to use DirectX for sound in this old app on windows 10? Any example would be great.
Thanks....
While I cannot guarantee this is the fix, I also cannot just comment because I don't have 50 rep, it is worth a try. I had a lot of issues with Windows 10 sound, often it seemed at random! Switching apps disabled sound from background apps, game programming wouldn't make a peep, even playing music to see if I had the right track with CD burning software was broken, Netflix breaking sound until I rebooted, wireless headphones not working or volume way too low. Infuriating. You might not be wrestling control from whatever has current priority because of an W10 April 2018 change and just not had the issues I've had.
Anyway, this is worth a try:
Right-click the Sound Icon in the bottom right of task bar. Click
Playback or Audio Devices. Right-click the speaker icon that appears
in the settings screen. Click Properties from the pop-up menu. Click
the Advanced tab on the Speakers Properties screen. Uncheck the boxes
for Allow applications to take exclusive control and Give exclusive
mode applications priority.
I've solved this. At the end it wasn't anything with DirectX.
hfile := LZOpenFile(PAnsiChar(fn), vreopenbuff, OF_READ);
Parameter "fn" (string) that was input to the procedure was wrong. Something messes up. The file name was incorrect, so file that should be played was empty. Nothing to do with DirectX. I've replaced above command with:
hfile := LZOpenFile(PAnsiChar(AnsiString(fn)), vreopenbuff, OF_READ);
Now it is working.
Thanks...

Delphi datasnap send an from image to server (to be stored in database)

I have searched high and low for a working solution for sending an image (e.g. tpngimage) to the server using a datasnap method - but I cannot make it to work.
When I load the image and save it to a memorystream, I'm able to read the image back from the stream - locally in the client, which is not really a surprise. But when the server method gets called, the stream is nil and contains nothing, the other parameters are fine (simple datatype and an object).
Did I miss something obvious here? I was under the impression that TStream is a valid datatype for datasnap methods, but maybe I'm wrong?
The from client side it looks like this.
function TPerson.Update: Boolean;
var
AStream : TMemoryStream;
APicture : TPngImage;
ASize : Integer;
begin
if (FId > 0) then // if Id below zero we have a problem
begin
ClientModule1.ServerMethods1Client.UpdatePerson(Self);
APicture := TPngImage.Create;
AStream := TMemoryStream.Create;
try
// Temp just use a file
AStream.LoadFromFile('.\images\075.png');
ASize := AStream.Size;
AStream.Position := 0; // wind back if needed
// just for testing, we can read back the image from the stream
APicture.LoadFromStream(AStream);
ClientModule1.ServerMethods1Client.UpdatePersonPicture(self, ASize, AStream);
finally
FreeAndNil(AStream);
FreeAndNil(APicture);
end;
end;
FModified := False;
end;
And the proxy method looks like this
procedure TServerMethods1Client.UpdatePersonPicture(APerson: TPerson; ASize: Integer; APictureStream: TMemoryStream);
begin
if FUpdatePersonPictureCommand = nil then
begin
FUpdatePersonPictureCommand := FDBXConnection.CreateCommand;
FUpdatePersonPictureCommand.CommandType := TDBXCommandTypes.DSServerMethod;
FUpdatePersonPictureCommand.Text := 'TServerMethods1.UpdatePersonPicture';
FUpdatePersonPictureCommand.Prepare;
end;
if not Assigned(APerson) then
FUpdatePersonPictureCommand.Parameters[0].Value.SetNull
else
begin
FMarshal := TDBXClientCommand(FUpdatePersonPictureCommand.Parameters[0].ConnectionHandler).GetJSONMarshaler;
try
FUpdatePersonPictureCommand.Parameters[0].Value.SetJSONValue(FMarshal.Marshal(APerson), True);
if FInstanceOwner then
APerson.Free
finally
FreeAndNil(FMarshal)
end
end;
FUpdatePersonPictureCommand.Parameters[1].Value.SetInt32(ASize);
FUpdatePersonPictureCommand.Parameters[2].Value.SetStream(APictureStream, FInstanceOwner);
FUpdatePersonPictureCommand.ExecuteUpdate;
end;
The Server method looks like this - it fails due to the APictureStream is nil.
procedure TServerMethods1.UpdatePersonPicture(APerson: TPerson; ASize: integer;
APictureStream: TMemoryStream);
var
APicture : TPngImage;
begin
fdqPersons.Close;
fdqPersons.SQL.Clear;
fdqPersons.Connection.StartTransaction;
try
fdqPersons.SQL.Add('update Persons set Picture=:Picture ');
fdqPersons.SQL.Add('where Id=:Id');
fdqPersons.ParamByName('Id').Value := APerson.Id;
APicture := TPngImage.Create;
try
// APicture for testing - but APictureStream is nil!
APicture.LoadFromStream(APictureStream);
fdqPersons.ParamByName('Picture').Assign(APicture);
fdqPersons.ExecSQL;
finally
FreeAndNil(APicture);
end;
fdqPersons.Close;
fdqPersons.Connection.Commit;
LogEvent(format('Person picture updated ID: %d',[APerson.id]));
except
on e:exception do
begin
fdqPersons.Connection.Rollback;
LogEvent(format('Error updating person picture %s',[e.Message]));
raise;
end;
end;
end;
When you call APicture.LoadFromStream(AStream); the stream's position goes to the end, and therefore when passing it into ClientModule1 it does not have any data left to be read. Either get rid of the unnecessary portion where you write the stream to a TPngImage or reset the stream's position back to 0 just after that part.

Suspend/resume processes as PsSuspend does

I hope this post is not a duplicate one. Let me explain:
I have considered the similar post How to pause / resume any external process under Windows? but with C++/Python preference and yet without an accepted answer as of the time of posting.
My Question:
I'm interested in a possible implementation in Delphi of the functionality provided by PsSuspend by Mark Russinovich of Windows Sysinternals.
Quotes:
PsSuspend lets you suspend processes on the local or a remote system,
which is desirable in cases where a process is consuming a resource
(e.g. network, CPU or disk) that you want to allow different processes
to use. Rather than kill the process that's consuming the resource,
suspending permits you to let it continue operation at some later
point in time.
Thank you.
Edit:
A partial implementation will do. Remote capability can be dropped.
You can try to use the following code. It uses the undocumented functions NtSuspendProcess and NtResumeProcess. I've tried it on Windows 7 64-bit from the 32-bit application built in Delphi 2009 and it works for me. Note that these functions are undocumented thus can be removed from future versions of Windows.
Update
The SuspendProcess and ResumeProcess wrappers from the following code are now functions and returns True if succeed, False otherwise.
type
NTSTATUS = LongInt;
TProcFunction = function(ProcHandle: THandle): NTSTATUS; stdcall;
const
STATUS_SUCCESS = $00000000;
PROCESS_SUSPEND_RESUME = $0800;
function SuspendProcess(const PID: DWORD): Boolean;
var
LibHandle: THandle;
ProcHandle: THandle;
NtSuspendProcess: TProcFunction;
begin
Result := False;
LibHandle := SafeLoadLibrary('ntdll.dll');
if LibHandle <> 0 then
try
#NtSuspendProcess := GetProcAddress(LibHandle, 'NtSuspendProcess');
if #NtSuspendProcess <> nil then
begin
ProcHandle := OpenProcess(PROCESS_SUSPEND_RESUME, False, PID);
if ProcHandle <> 0 then
try
Result := NtSuspendProcess(ProcHandle) = STATUS_SUCCESS;
finally
CloseHandle(ProcHandle);
end;
end;
finally
FreeLibrary(LibHandle);
end;
end;
function ResumeProcess(const PID: DWORD): Boolean;
var
LibHandle: THandle;
ProcHandle: THandle;
NtResumeProcess: TProcFunction;
begin
Result := False;
LibHandle := SafeLoadLibrary('ntdll.dll');
if LibHandle <> 0 then
try
#NtResumeProcess := GetProcAddress(LibHandle, 'NtResumeProcess');
if #NtResumeProcess <> nil then
begin
ProcHandle := OpenProcess(PROCESS_SUSPEND_RESUME, False, PID);
if ProcHandle <> 0 then
try
Result := NtResumeProcess(ProcHandle) = STATUS_SUCCESS;
finally
CloseHandle(ProcHandle);
end;
end;
finally
FreeLibrary(LibHandle);
end;
end;
There is no SuspendProcess API call in Windows. So what you need to do is:
Enumerate all the threads in the process. See RRUZ's answer for sample code.
Call SuspendThread for each of these threads.
In order to implement the resume part of the program, call ResumeThread for each thread.
There is a race condition for the "suspend all threads" implementation - what happens if the program you are trying to suspend creates one or more threads between the time that you create the snapshot and the time that you complete suspending?
You could loop, getting another snapshot and suspending any unsuspending threads, exiting only when you found none.
The undocumented function avoids this issue.
I just found the following snippets here (Author: steve10120).
I think they are valuables and I can't help posting them also as an alternative answer to my own question.
Resume Process:
function ResumeProcess(ProcessID: DWORD): Boolean;
var
Snapshot,cThr: DWORD;
ThrHandle: THandle;
Thread:TThreadEntry32;
begin
Result := False;
cThr := GetCurrentThreadId;
Snapshot := CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, 0);
if Snapshot <> INVALID_HANDLE_VALUE then
begin
Thread.dwSize := SizeOf(TThreadEntry32);
if Thread32First(Snapshot, Thread) then
repeat
if (Thread.th32ThreadID <> cThr) and (Thread.th32OwnerProcessID = ProcessID) then
begin
ThrHandle := OpenThread(THREAD_ALL_ACCESS, false, Thread.th32ThreadID);
if ThrHandle = 0 then Exit;
ResumeThread(ThrHandle);
CloseHandle(ThrHandle);
end;
until not Thread32Next(Snapshot, Thread);
Result := CloseHandle(Snapshot);
end;
end;
Suspend Process:
function SuspendProcess(PID:DWORD):Boolean;
var
hSnap: THandle;
THR32: THREADENTRY32;
hOpen: THandle;
begin
Result := FALSE;
hSnap := CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, 0);
if hSnap <> INVALID_HANDLE_VALUE then
begin
THR32.dwSize := SizeOf(THR32);
Thread32First(hSnap, THR32);
repeat
if THR32.th32OwnerProcessID = PID then
begin
hOpen := OpenThread($0002, FALSE, THR32.th32ThreadID);
if hOpen <> INVALID_HANDLE_VALUE then
begin
Result := TRUE;
SuspendThread(hOpen);
CloseHandle(hOpen);
end;
end;
until Thread32Next(hSnap, THR32) = FALSE;
CloseHandle(hSnap);
end;
end;
Disclaimer:
I didn't test them at all. Please enjoy and don't forget to feedback.

How to find the name of the parent program that started us?

We want a program of ours in D7 to know if it was run via a ShellExecute command from one of our apps, or directly started by the user.
Is there a reliable way for a Delphi 7 program to determine the name of the program that ran it?
We of course could have our parent program use a command line argument or other flag, but we'd prefer the above approach.
TIA
There's no way to do what you want, I'm afraid. The application isn't told whether it's being run pro grammatically via ShellExecute (or CreateProcess), via a command line, a shortcut, or a double-click in Explorer.
Raymond Chen did an article a while back on this very topic, if I remember correctly; I'll see if I can find it and update my answer here.
Based on another answer and some code on Torry.net, I came to this function to get the parent process id. It seems to return a relevant number on Windows 7, and the windows functions it uses should be available at least since Win 2000.
uses Tlhelp32;
function GetProcessInfo(ProcessId: Cardinal; out ParentProcessId: Cardinal; out ExeFileName: string): Boolean;
var
hSnapShot: THandle;
ProcInfo: TProcessEntry32;
begin
hSnapShot := CreateToolHelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if (hSnapShot <> THandle(-1)) then
try
ProcInfo.dwSize := SizeOf(ProcInfo);
if (Process32First(hSnapshot, ProcInfo)) then
repeat
if ProcInfo.th32ProcessID = ProcessId then
begin
ExeFileName := string(ProcInfo.szExeFile);
ParentProcessId := ProcInfo.th32ParentProcessID;
Result := True;
Exit;
end;
until not Process32Next(hSnapShot, ProcInfo);
finally
CloseHandle(hSnapShot);
end;
Result := False;
end;
procedure Test;
var
ProcessId, ParentProcessId, Dummy: Cardinal;
FileName: string;
begin
ProcessId := GetCurrentProcessId();
// Get info for current process
if GetProcessInfo(ProcessId, ParentProcessId, FileName) then
// Get info for parent process
if GetProcessInfo(ParentProcessId, Dummy, FileName) then
// Show it.
ShowMessage(IntToStr(ParentProcessId) + FileName);
end;
A word of caution! The parent process may no longer exist. Even worse, it's ID may have been recycled, causing this function to give you a different process than you asked for.
The simple answer is "No".
A more complex answer is "Not as easily as simply passing a command line param would be".
:)
What you need to do is identify the parent process of your process. Obtaining this is possible but not straightforward. Details of how to go about it can be obtained in this CodeProject article.
The biggest problem is that there is not strict hierarchical relationship between processes in Windows and PID (Process ID's) may be re-used. The PID you identify as your "parent" may not be your parent at all. If the parent process has subsequently terminated then it's PID may be re-used which could lead to some seemingly perplexing results ("My process was started by calc.exe? How is that possible?").
Trying to find bullet, water and idiot proof mechanisms to protect against the possible ways such a process might fail will be significantly more effort than simply devising and implementing a command line based convention between your launcher applications and the launchee by which the latter may identify the former.
A command line parameter is one such option but could be "spoofed" (if someone figures out what you are passing on the command line and for some reason could derive some value or benefit from mimicking this themselves).
Depending on how reliable and tamper proof you need the mechanism to be, this could still be enough however.
I've found getpids which does it using NtQueryInformationProcess to not only to obtain the parent process ID but also compare the process creation times - if the reported parent process was created after the child it means the reported parent ID has already been recycled.
Here is my Delphi unit I wrote to test it:
unit ProcInfo;
interface
uses
Windows, SysUtils;
function GetParentProcessId(ProcessID: DWORD; out ProcessImageFileName: string): DWORD; overload;
implementation
uses
PsApi;
var
hNtDll: THandle;
NtQueryInformationProcess: function(ProcessHandle: THandle; ProcessInformationClass: DWORD;
ProcessInformation: Pointer; ProcessInformationLength: ULONG; ReturnLength: PULONG): DWORD; stdcall;
const
UnicodeStringBufferLength = 1025;
type
PPEB = Pointer; // PEB from winternl.h not needed here
PPROCESS_BASIC_INFORMATION = ^PROCESS_BASIC_INFORMATION;
PROCESS_BASIC_INFORMATION = record
Reserved1: Pointer; // exit status
PebBaseAddress: PPEB;
Reserved2: array[0..1] of Pointer; // affinity mask, base priority
UniqueProcessId: ULONG_PTR;
Reserved3: Pointer; // parent process ID
end;
PProcessBasicInformation = ^TProcessBasicInformation;
TProcessBasicInformation = PROCESS_BASIC_INFORMATION;
PKernelUserTimes = ^TKernelUserTimes;
TKernelUserTimes = record
CreateTime: LONGLONG;
ExitTime: LONGLONG;
KernelTime: LONGLONG;
UserTime: LONGLONG;
end;
PUNICODE_STRING = ^UNICODE_STRING;
UNICODE_STRING = record
Length: USHORT;
MaximumLength: USHORT;
PBuffer: PChar;
Buffer: array[0..UnicodeStringBufferLength - 1] of Char;
end;
PUnicodeString = ^TUnicodeString;
TUnicodeString = UNICODE_STRING;
function GetProcessCreateTime(hProcess: THandle): LONGLONG;
var
ProcessTimes: TKernelUserTimes;
begin
Result := 0;
FillChar(ProcessTimes, SizeOf(ProcessTimes), 0);
if NtQueryInformationProcess(hProcess, 4, #ProcessTimes, SizeOf(ProcessTimes), nil) <> 0 then
Exit;
Result := ProcessTimes.CreateTime;
end;
function GetProcessParentId(hProcess: THandle): DWORD;
var
ProcessInfo: TProcessBasicInformation;
begin
Result := 0;
FillChar(ProcessInfo, SizeOf(ProcessInfo), 0);
if NtQueryInformationProcess(hProcess, 0, #ProcessInfo, SizeOf(ProcessInfo), nil) <> 0 then
Exit;
Result := DWORD(ProcessInfo.Reserved3);
end;
function GetProcessImageFileName(hProcess: THandle): string;
var
ImageFileName: TUnicodeString;
begin
Result := '';
FillChar(ImageFileName, SizeOf(ImageFileName), 0);
ImageFileName.Length := 0;
ImageFileName.MaximumLength := UnicodeStringBufferLength * SizeOf(Char);
ImageFileName.PBuffer := #ImageFileName.Buffer[0];
if NtQueryInformationProcess(hProcess, 27, #ImageFileName, SizeOf(ImageFileName), nil) <> 0 then
Exit;
SetString(Result, ImageFileName.PBuffer, ImageFileName.Length);
end;
function GetParentProcessId(ProcessId: DWORD; out ProcessImageFileName: string): DWORD;
var
hProcess, hParentProcess: THandle;
ProcessCreated, ParentCreated: LONGLONG;
begin
Result := 0;
ProcessImageFileName := '';
hProcess := OpenProcess(PROCESS_QUERY_INFORMATION, False, ProcessId);
if hProcess = 0 then
RaiseLastOSError;
try
Result := GetProcessParentId(hProcess);
if Result = 0 then
Exit;
ProcessCreated := GetProcessCreateTime(hProcess);
finally
CloseHandle(hProcess);
end;
hParentProcess := OpenProcess(PROCESS_QUERY_INFORMATION, False, Result);
if hParentProcess = 0 then
RaiseLastOSError;
try
ParentCreated := GetProcessCreateTime(hParentProcess);
if ParentCreated > ProcessCreated then
begin
Result := 0;
Exit;
end;
ProcessImageFileName := GetProcessImageFileName(hParentProcess);
finally
CloseHandle(hParentProcess);
end;
end;
initialization
hNtDll := GetModuleHandle('ntdll.dll');
if hNtDll <> 0 then
NTQueryInformationProcess := GetProcAddress(hNtDll, 'NtQueryInformationProcess');
end.
When I run the code from the IDE, I get the following results:
parent ID: 5140, parent image file name:
"\Device\HarddiskVolume1\Program Files\Embarcadero\RAD
Studio\8.0\bin\bds.exe"
so you may need to find a way to translate that into a "normal" path, e.g. "C:\Program Files\Embarcadero\RAD Studio\8.0\bin\bds.exe".

Delphi function comparing content of two TStream?

I need to compare if two TStream descendant have the same content.
The only interesting result for me is the boolean Yes / No.
I'm going to code a simple loop checking byte after byte the streams content's.
But I'm curious to know if there is an already existing function. I haven't found any inside DelphiXE or JCL/JVCL libs.
Of course, the two streams have the same size !
Exactly, as Nickolay O. said you should read your stream in blocks and use CompareMem. Here is an example (including size test) ...
function IsIdenticalStreams(Source, Destination: TStream): boolean;
const Block_Size = 4096;
var Buffer_1: array[0..Block_Size-1] of byte;
Buffer_2: array[0..Block_Size-1] of byte;
Buffer_Length: integer;
begin
Result := False;
if Source.Size <> Destination.Size then
Exit;
while Source.Position < Source.Size do
begin
Buffer_Length := Source.Read(Buffer_1, Block_Size);
Destination.Read(Buffer_2, Block_Size);
if not CompareMem(#Buffer_1, #Buffer_2, Buffer_Length) then
Exit;
end;
Result := True;
end;
The IsIdenticalStreams function posted by daemon_x is excellent - but needs one adjustment to work properly. (Uwe Raabe caught the issue already.) It is critical that you reset the stream positions before starting the loop - or this procedure will probably return an incorrect TRUE if the two streams were already accessed outside this function.
This is the final solution that works every time. I just renamed the function to suit my naming conventions. Thank you daemon_x for the elegant solution.
function StreamsAreIdentical(Stream1, Stream2: TStream): boolean;
const
Block_Size = 4096;
var
Buffer_1: array[0..Block_Size-1] of byte;
Buffer_2: array[0..Block_Size-1] of byte;
Buffer_Length: integer;
begin
Result := False;
if Stream1.Size <> Stream2.Size then exit;
// These two added lines are critical for proper operation
Stream1.Position := 0;
Stream2.Position := 0;
while Stream1.Position < Stream1.Size do
begin
Buffer_Length := Stream1.Read(Buffer_1, Block_Size);
Stream2.Read(Buffer_2, Block_Size);
if not CompareMem(#Buffer_1, #Buffer_2, Buffer_Length) then exit;
end;
Result := True;
end;
There is no such built-in function. Only one thing I can recommend - read not byte-to-byte, but using blocks of 16-64kbytes, that would be much faster.
Answers from user532231 and Mike are working in 99% cases, but there are additional checks to be made!
Descendants of TStream can be almost anything, so it's not guaranteed that Stream.Read will return same amount of data, even if streams are of the same length (stream descendant can also download data, so may return readed=0 bytes, while waiting for next chunk). Streams can be also on completelly different media and stream read error could occur on just one.
For 100% working code all these checks should be made. I modified the function from Mike.
If this function is used for example to rewrite stream 2 if not identical to Stream1, all errors should be checked. When function result is True, everthing is ok, but if it is False, it would be very smart to check if Streams are actually different or just some error occured.
Edited: Added some additional checks, FilesAreIdentical function based on StreamsAreIdentical and usage example.
// Usage example
var lError: Integer;
...
if FilesAreIdentical(lError, 'file1.ext', 'file2.ext')
then Memo1.Lines.Append('Files are identical.')
else case lError of
0: Memo1.Lines.Append('Files are NOT identical!');
1: Memo1.Lines.Append('Files opened, stream read exception raised!');
2: Memo1.Lines.Append('File does not exist!');
3: Memo1.Lines.Append('File open exception raised!');
end; // case
...
// StreamAreIdentical
function StreamsAreIdentical(var aError: Integer;
const aStream1, aStream2: TStream;
const aBlockSize: Integer = 4096): Boolean;
var
lBuffer1: array of byte;
lBuffer2: array of byte;
lBuffer1Readed,
lBuffer2Readed,
lBlockSize: integer;
begin
Result:=False;
aError:=0;
try
if aStream1.Size <> aStream2.Size
then Exit;
aStream1.Position:=0;
aStream2.Position:=0;
if aBlockSize>0
then lBlockSize:=aBlockSize
else lBlockSize:=4096;
SetLength(lBuffer1, lBlockSize);
SetLength(lBuffer2, lBlockSize);
lBuffer1Readed:=1; // just for entering while
while (lBuffer1Readed > 0) and (aStream1.Position < aStream1.Size) do
begin
lBuffer1Readed := aStream1.Read(lBuffer1[0], lBlockSize);
lBuffer2Readed := aStream2.Read(lBuffer2[0], lBlockSize);
if (lBuffer1Readed <> lBuffer2Readed) or ((lBuffer1Readed <> lBlockSize) and (aStream1.Position < aStream1.Size))
then Exit;
if not CompareMem(#lBuffer1[0], #lBuffer2[0], lBuffer1Readed)
then Exit;
end; // while
Result:=True;
except
aError:=1; // stream read exception
end;
end;
// FilesAreIdentical using function StreamsAreIdentical
function FilesAreIdentical(var aError: Integer;
const aFileName1, aFileName2: String;
const aBlockSize: Integer = 4096): Boolean;
var lFileStream1,
lFilestream2: TFileStream;
begin
Result:=False;
try
if not (FileExists(aFileName1) and FileExists(aFileName2))
then begin
aError:=2; // file not found
Exit;
end;
lFileStream1:=nil;
lFileStream2:=nil;
try
lFileStream1:=TfileStream.Create(aFileName1, fmOpenRead or fmShareDenyNone);
lFileStream2:=TFileStream.Create(aFileName2, fmOpenRead or fmShareDenyNone);
result:=StreamsAreIdentical(aError, lFileStream1, lFileStream2, aBlockSize);
finally
if lFileStream2<>nil
then lFileStream2.Free;
if lFileStream1<>nil
then lFileStream1.Free;
end; // finally
except
aError:=3; // file open exception
end; // except
end;

Resources