I want to track long running operations on idHTTPServer from idHTTPClient by ping. How would I do that better way ? I need something unique for that. I tried with bind.id but with no success.
lets say i give something unique when thread is started it job
procedure TRPTests.SomeServerJob;
var
jo: ISuperObject;
begin
TThread.CreateAnonymousThread(
procedure()
begin
Sleep(3000);
end).Start();
jo := SO();
jo.S['BindId'] := Context.Binding.ID.ToString;
FResponses.OkWithJson(jo.AsJSon(false, false));
end;
In some time later i want to check if job is done or what is progress?
lets say i tried to do this that way
procedure TRPSystem.PingContext(aId: string);
var
jo: ISuperObject;
i: integer;
r: boolean;
someProgress: string;
begin
with GetMain.Server.Contexts.LockList() do
try
for i := 0 to Count - 1 do
if TIdContext(Items[i]).Binding.ID = aId.ToInteger then
begin
someProgress := '10 %'; // take progress param from my thread
r := true;
Break;
end;
finally
GetMain.Server.Contexts.UnlockList();
end;
if r then
begin
jo := SO;
jo.I['progress'] := someProgress;
FResponses.OkWithJson(jo.AsJSon(false, false));
end;
end;
Is that correct approach or better use another one ?
Related
Following _isEdit function detects whether input could be applied to the currently focused control:
class function TSpeedInput._getFocusedControlClassName(): WideString;
var
lpClassName: array[0..1000] of WideChar;
begin
FillChar(lpClassName, SizeOf(lpClassName), 0);
Windows.GetClassNameW(GetFocus(), PWideChar(#lpClassName), 999);
Result := lpClassName;
end;
class function TSpeedInput._isEdit(): Boolean;
const
CNAMES: array[0..3] of string = ('TEdit', 'TMemo', 'TTntMemo.UnicodeClass',
'TTntEdit.UnicodeClass');
var
cn: WideString;
i: Integer;
begin
Result := False;
cn := _getFocusedControlClassName();
for i := Low(CNAMES) to High(CNAMES) do
if cn = CNAMES[i] then begin
Result := True;
Exit;
end;
//MessageBoxW(0, PWideChar(cn), nil, 0);
end;
What I don't like about it is the hard coding of the class name list. Could it be detected that a currently focused window belongs to the editors family or, better to say, that it has an active caret? (in order that _isEdit returns False for a WhateverItIsControl that is in read-only mode).
If the Handle of the control is allocated, you can use this hack:
function IsEdit(AControl: TWinControl): boolean;
begin
if AControl.HandleAllocated then
begin
Result := SendMessage(AControl.Handle, EM_SETREADONLY,
WPARAM(Ord(AControl.Enabled)), 0) <> 0;
end
else
begin
Result := AControl is TCustomEdit;
end;
end;
If the controls you are interested in are on a specific form and are owned by that form (and are standard Delphi controls) you could use the following:
function TFormML2.FocusIsEdit: boolean;
var
i : integer;
begin
Result := FALSE;
for i := 0 to ComponentCount - 1 do
begin
if Components[ i ] is TCustomEdit then
begin
if (Components[ i ] as TCustomEdit).Focused and not (Components[ i ] as TCustomEdit).ReadOnly then
begin
Result := TRUE;
break;
end;
end;
end;
end;
If you know the form and can pass it as a parameter, you could do something similar.
TCustomEdit is the ancestor of all edit boxes, memos, etc.
I'm trying to make progressbar while deleting files here is my code:
procedure TForm1.Timer1Timer(Sender: TObject);
var
i:Integer;
begin
i:=i+1;
ProgressBar.Max:=DeleteList.Count - i ; //Files = 8192
DeleteFile(GetIniString('List', 'File' + IntToStr(i),'','FileLists.ini'));
ProgressBar.Position:=ProgressBar.Position+1;
end;
Using threads or IFileOperation both involve fairly steep learning curves. Here are a couple of possibilities:
TDirectory method
At Jerry Dodge's prompting I decided to add an example of using TDirectory to
get a list of files and process it in some way, e.g. delete files in the list.
It displays a periodic progress message - see the if i mod 100 = 0 then statement
in the ProcessFiles method. Unfortunately I couldn't find a way to show
a periodic message during the list-building stage because AFAIC TDirectory
doesn't expose the necessary hook to do so.
procedure TForm2.ProcessFileList(FileList : TStringList);
var
i : Integer;
S : String;
begin
for i := 0 to FileList.Count - 1 do begin
// do something with FileList[i], e.g. delete it
S := FileList[i];
DeleteFile(S);
// Display progress
if i mod 100 = 0 then // do something to show progress
Caption := Format('Files processed: %d ', [i]);
// OR, you could use i and FileList.Count to set a trackbar % complete
end;
Caption := Format('Processed: %d files', [FileList.Count]);
end;
procedure TForm2.GetFileList(const Path : String; FileList : TStringList);
var
Files : Types.TStringDynArray;
i : Integer;
begin
Files := TDirectory.GetFiles('C:\Temp');
FileList.BeginUpdate;
try
for i:= 0 to Length(Files) - 1 do
FileList.Add(Files[i]);
finally
FileList.EndUpdate;
end;
end;
procedure TForm2.Button1Click(Sender: TObject);
var
FileList : TStringList;
begin
FileList := TStringList.Create;
try
GetFileList('C:\Temp', FileList);
ProcessFileList(FileList);
Memo1.Lines.Text := FileList.Text;
finally
FileList.Free;
end;
end;
It should be evident that this way of doing it is a lot simpler than using the
traditional, Windows-specific method below, at the expense of loss of some flexibility,
and has the advantage of being cross-platform.
IFileOperation method (Windows-specific)
The Windows API has functionality to retrieve and process a list of files e.g. in a directory and there used to be a trivially-simple-to-use wrapper around this, including a progress animation, in the (antique) v.3 of SysTools library from TurboPower S/Ware, but I'm not sure this wrapper ever made it into the later public domain version. On the face if it, it could also be done using the IFileOperation interface but google has yet to conjure a simple example. Note that an SO answer about this contains the comment "this is a very complex API and you do need to read the documentation carefully".
I attempted to do this myself but soon got out of my depth. Remy Lebeau's answer here to the q I posted when I got stuck shows how to do it, but the TDirectory method above seems vastly easier at my skill level.
Traditional (D7) method (Windows-specific)
In my experience, if you are only looking to process a few hundred thousand files, you should be able to do it, displaying progress as you go, by adding the files to a TStringList and then processing that, with code along the following lines:
procedure GetFileList(const Path : String; Recurse : Boolean; FileList : TStringList);
// Beware that the following code is Windows-specific
var
FileCount : Integer;
procedure GetFilesInner(sPath : String);
var
Path,
AFileName,
Ext: String;
Rec: TSearchRec;
Done: Boolean;
begin
Path := IncludeTrailingBackslash(sPath);
if FindFirst(Path + '*.*', faAnyFile, Rec) = 0 then begin
Done := False;
while not Done do begin
if (Rec.Name <> '.') and (Rec.Name <> '..') then begin
AFileName := Path + Rec.Name;
Ext := LowerCase(ExtractFileExt(AFileName));
if not ((Rec.Attr and faDirectory) = faDirectory) then begin
inc(FileCount);
if FileCount mod 100 = 0 then
//show progress in GUI
;
FileList.Add(AFileName)
end
else begin
if Recurse then
GetFilesInner(AFileName);
end;
end;
Done := FindNext(Rec) <> 0;
end;
FindClose(Rec);
end;
end;
begin
FileCount := 0;
FileList.BeginUpdate;
FileList.Sorted := True;
FileList.Duplicates := dupIgnore; // don't add duplicate filenames to the list
GetFilesInner(Path);
FileList.EndUpdate;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
FileList : TStringList;
FileName : String;
i : Integer;
begin
FileList := TStringList.Create;
try
GetFileList('d:\aaad7', True, FileList);
for i := 0 to FileList.Count - 1 do begin
FileName := FileList[i];
// do something with FileName, e.g. delete the file
if i mod 100 = 0 then
// display progess e.g. by
Caption := IntToStr(i);
end;
Memo1.Lines := FileList;
finally
FileList.Free;
end;
end;
The if [...] mod [...] = 0 then statements are where you can show the two phases' progress howver you want.
Btw, this code was olny intended to get you started. I'm obliged to Jerry Dodge for reminding me that in recent versions of Delphi, there is similar functionality built-in, by way of the TDirectory.GetFiles method so if you are interested in cross-platform and/or accommodate Unicode, you would do better to study the ins and outs of TDirectory and non-Windows-specific routines like TrailingPathDelim.
When you really want to show some progress in a UI when deleting files, you should use threads:
create a thread, which deletes the files
then poll the progress of the deletion thread from the UI
Be careful when using threads, not to access UI parts (like the progressbar) from within the deletion thread. Such things should at least be synchronized.
I have a function to update a cxGrid made with help from answers to Loop through records on a cxgrid and update a field/column
But it is sometimes acting a bit strange. If I open the form with the cxGrid and click the columnheader without doing anything else, the records are updateted OK. But if the 'selectorbar' is moved away from the top, the record marked is not updated.
I am sure it is a property that needs to be changed, but which one.
The variable fSelected is set to False at FormShow and is ther so that the user can unselect records as well.
procedure TfrmContactsSelect.colContactSelectedHeaderClick(Sender: TObject);
var
i: Integer;
Index: Integer;
BookMark : TBookMark;
Contact: variant;
begin
if fMulti = True then
begin
Screen.Cursor := crHourGlass;
fSelected := not fSelected;
BookMark := qryContacts.GetBookmark;
qryContacts.DisableControls;
try
for i := 0 to grdContactsView1.DataController.FilteredRecordCount - 1 do
begin
Index := grdContactsView1.DataController.FilteredRecordIndex[i];
Contact := grdContactsView1.DataController.Values[Index, 4];
if grdContactsView1.DataController.LocateByKey(Contact) then
begin
qryContacts.Edit;
qryContacts.FieldByName('fldcontact_selected').AsBoolean := fSelected;
qryContacts.Post;
end;
end;
finally
qryContacts.EnableControls;
qryContacts.GotoBookmark(BookMark);
qryContacts.FreeBookmark(BookMark);
end;
Screen.Cursor := crDefault;
end;
end;
Delphi XE7, DevExpress 14.2.2, UniDAC 5.5.12 for DB access
Comment:
I have ended up with the following solution based on the answer and input from MartynA
procedure TfrmContactsSelect.colContactSelectedHeaderClick(Sender: TObject);
var
i: Integer;
Index: Integer;
MarkedRecord: variant;
CurrentRecord: variant;
begin
if fMulti = True then
begin
Screen.Cursor := crHourGlass;
fSelected := not fSelected;
Index := grdContactsView1.DataController.FocusedRecordIndex;
MarkedRecord := grdContactsView1.DataController.Values[Index, colContactGuid.ID];
try
for i := 0 to grdContactsView1.DataController.FilteredRecordCount - 1 do
begin
Index := grdContactsView1.DataController.FilteredRecordIndex[i];
CurrentRecord := grdContactsView1.DataController.Values[Index, colContactGuid.ID];
if grdContactsView1.DataController.LocateByKey(CurrentRecord) then
begin
grdContactsView1.DataController.Edit;
grdContactsView1.DataController.SetEditValue(colContactSelected.ID, fSelected, evsText);
grdContactsView1.DataController.Post;
end;
end;
finally
grdContactsView1.DataController.LocateByKey(MarkedRecord);
end;
Screen.Cursor := crDefault;
end;
end;
I can reproduce your problem using the sample project I posted in my answer to your other q.
Try this: Add a TMemo to your form, and inside the 'if grdContactsView1.DataController.LocateByKey(Contact) then' block, write the value of a row-unique datafield and the Selected datafield value to the memo.
Then, what I get when some row other than the top row is selected is that one row is listed twice in the memo, with Selected both false and true, and one of the rows in the filter isn't listed at all, which I think accounts for the behaviour you're seeing. If I then comment out the .Edit .. .Post lines, it correctly lists all the rows in the filter.
So evidently doing the Selected field changes inside a block which iterated the FilteredRecordIndex property of the DBTableView is what's causing the problem.
Personally, I find that it goes a bit against the grain to modify dataset rows in code via a DB-aware control (because you usually end up fighting the DB-awareness of the control), but in this case, it's straightforward to do the processing via the DBTableView of the cxGrid.
procedure TForm1.ProcessFilteredRecords;
var
PrevV,
V : Variant;
i,
Index: Integer;
S : String;
begin
// First, pick up a reference to the current record
// so that we can return to it afterwards
Index := cxGrid1DBTableView1.DataController.FocusedRecordIndex;
PrevV := cxGrid1DBTableView1.DataController.Values[Index, 0];
try
for i := 0 to cxGrid1DBTableView1.DataController.FilteredRecordCount - 1 do begin
Index := cxGrid1DBTableView1.DataController.FilteredRecordIndex[i];
V := cxGrid1DBTableView1.DataController.Values[Index, 0];
if cxGrid1DBTableView1.DataController.LocateByKey(V) then begin
cxGrid1DBTableView1.DataController.Edit;
// 2 is the index of my Selected column in the grid
if cxGrid1DBTableView1.DataController.SetEditValue(2, True, evsText) then
Caption := 'OK'
else
Caption := 'Failed';
cxGrid1DBTableView1.DataController.Post;
end;
end;
finally
if cxGrid1DBTableView1.DataController.LocateByKey(PrevV) then
Caption := 'OK'
else
Caption := 'Failed';
end;
end;
Another way to avoid the problem is to change the Selected states in two steps:
Iterate the FilteredRecordIndex to build a list of rows to change - in your case this would be a list of guids
Then, iterate the list of rows and update their Selected states.
Code:
procedure TForm1.ProcessFilteredRecords;
var
V : Variant;
i,
Index: Integer;
BM : TBookMark;
S : String;
TL : TStringList;
begin
Memo1.Lines.Clear;
TL := TStringList.Create;
try
for i := 0 to cxGrid1DBTableView1.DataController.FilteredRecordCount - 1 do begin
Index := cxGrid1DBTableView1.DataController.FilteredRecordIndex[i];
V := cxGrid1DBTableView1.DataController.Values[Index, 0];
if cxGrid1DBTableView1.DataController.LocateByKey(V) then begin
if CDS1.FieldByName('Selected').AsBoolean then
S := 'True'
else
S := 'False';
S := CDS1.FieldByName('Name').AsString + ' ' + S;
Memo1.Lines.Add(S);
TL.Add(CDS1.FieldByName('Guid').AsString);
end;
end;
try
BM := CDS1.GetBookMark;
CDS1.DisableControls;
for i := 0 to TL.Count - 1 do begin
if CDS1.Locate('guid', TL[i], []) then begin
CDS1.Edit;
CDS1.FieldByName('Selected').AsBoolean := True;
CDS1.Post;
end
end;
finally
CDS1.EnableControls;
CDS1.GotoBookmark(BM);
CDS1.FreeBookmark(BM);
end;
finally
TL.Free;
end;
end;
Like you, I was expecting that changing a property or two of the cxGrid might avoid the problem without any code, but I haven't been able to find anything which 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.
I'm trying to transfer some big streams (~1Mb) between DataSnap server/client but to no avail. I'm trying to understand the code of Jim Tierney (http://blogs.embarcadero.com/jimtierney/2009/04/06/31461) with no luck and i can't even compile the code because of a missing library, anyway ...
The max size of a stream i`m able to receive is 64k, so any tips/ideas/code samples you can provide for a weekend programmer like me will be very welcomed. Thank you!
my server code:
function TsrvMethods.getStream(iCount: integer): TStream;
begin
Result := dummyStream('0123456789', iCount);
end;
function dummyStream(sCnt: string; iCount: integer): TStream;
begin
Result := TMemoryStream.Create;
while iCount > 1 do begin
Result.Write(Pointer(sCnt)^, Length(sCnt));
Dec(iCount);
end;
Result.Seek(0, TSeekOrigin.soBeginning);
end;
my client calling code:
procedure TfrmMain.butStreamClick(Sender: TObject);
var
sStr : TStream;
begin
cycleConnection; //make sure we have an active connection
with TsrvMethodsClient.Create( SQLConn.DBXConnection, False ) do begin
sStr := getStream( Integer(SpinCount.Value) );
Free;
end;
FreeAndNil(sStr);
end;
Actually, i think i`ve got it. I'm posting this as an answer maybe somebody else need this.
procedure TfrmMain.butStreamClick(Sender: TObject);
const
iBufSize = 128;
var
sStr : TStream;
sMem : TMemoryStream;
buf: PByte;
iRead: integer;
begin
cycleConnection;
with TsrvMethodsClient.Create( SQLConn.DBXConnection, False ) do begin
sStr := getStream( 500000 ); //500k stream
GetMem(buf, iBufSize);
sMem := TMemoryStream.Create;
try
repeat
iRead := sStr.Read( Pointer(buf)^, iBufSize);
if iRead > 0 then sMem.WriteBuffer( Pointer(buf)^, iRead);
if iRead < iBufSize then break;
until iRead < iBufSize;
finally
FreeMem(buf, iBufSize);
end;
Free;
end;
FreeAndNil(sStr);
FreeAndNil(sMem);
end;
P.S.
Searching through DataSnap code samples i`ve found that one (speed related) improvement would be to have iBufSize set to 61440 (or equivalent hex value $F000) which seems to be the biggest size can be received in one go. If receiving stream is bigger then reported size will be -1 and the code above is needed to read the entire stream.