indy gettickdiff64() 18446744073709551600 problem - indy

I found that the gettickdiff64 function sometimes results in 18446744073709551600 (or 18446744073709551601) and causes the
program to run incorrectly.
Normally does not have a result greater than 300000
what might this be about?
Should I always do extra checks against this problem?
it is 32 bit VCL application.
I use Delphi 10.4.1( its indy version 10.6.2.0 )
Running on: 64 bit Windows Server 2012 R2 Foundation / intel xeon cpu E3-1225 v5 3.3 Ghz.
The code structure is as follows:
TMyClass = class
private
//.............
lastSetTime: uint64;
critic: TCriticalSection;
public
//.............
procedure setLastSetTime( ltime: uint64 );
function getLastSetTime: uint64;
end;
procedure TMyClass.setLastSetTime( ltime: uint64 );
begin
critic.enter;
try
lastSetTime := ltime;
finally
critic.leave;
end;
end;
function TMyClass.getLastSetTime: uint64;
begin
critic.enter;
try
result := lastSetTime;
finally
critic.leave;
end;
end;
...........
procedure controlAll(); //------>this is called from within thread every 5 minutes
var oki: boolean;
starttime, tdiff, ltime: uint64;
i: integer;
myC, sC: TMyClass;
begin
oki := false;
starttime := ticks64();
while ( oki = false ) and ( gettickdiff64( starttime, ticks64 ) < 40000 ) do
begin
//.........
//.........
sC := nil;
with myClassList.LockList do
try
if count > 0 then //---> has about 50000
begin
i := 0;
while i < count do
begin
myC := TMyClass( items[ i ] );
ltime := myC.getLastSetTime();
tdiff := gettickdiff64( ltime, ticks64() );
if tdiff > 50000 then
begin
logToFile( tdiff.ToString + ' ' + ltime.ToString ); //-----> every 5 minutes 50-60 log lines occur like this: 18446744073709551600 468528329
//..........
//.........
sC := myC;
delete( i );
break;
end;
inc( i );
end;
end;
finally
myClassList.UnlockList;
end;
if sC = nil then oki := true
else
begin
//..........
//..........
end;
end;
end;
The code structure that sets this value is as follows.
classListArray keeps all classes of TMyClass type grouped by server and channel number.
myClassList keeps all classes of type TMyClass attached one after the other without grouping.
classListArray is used to spend less CPU and process faster.
These two lists are not protected against each other when accessing classes.
Protection against each other is done only when adding and deleting classes.
classListArray: array[ 1..250, 1..12 ] of TThreadList;
//.................
procedure ServerExecute(AContext: TIdContext);
var Ath: TMypeer;
severNum, channelNum, clientNum, i, j, num: integer;
pSize: word;
stream: Tmemorystream;
packageNum: byte;
begin
try
Ath := TMypeer( AContext );
serverNum := Ath.getServerNum();
channelNum := Ath.getChannelNum();
Ath.SendQueue();
if AContext.Connection.IOHandler.InputBufferIsEmpty then
if not AContext.Connection.IOHandler.CheckForDataOnSource( 50 ) then Exit;
clientNum := AContext.Connection.IOHandler.ReadInt32( false );
pSize := AContext.Connection.IOHandler.ReadUInt16( false );
stream := TMemorystream.create;
try
AContext.Connection.IOHandler.ReadStream( stream, pSize );
stream.Seek( 0, soFromBeginning );
if clientNum <> 0 then
begin
//...........
end
else
begin
stream.ReadBuffer( packageNum, sizeof( packageNum ) );
if packageNum = 10 then
begin
stream.ReadBuffer( num, sizeof( num ) );
for i := 1 to num do
begin
stream.ReadBuffer( clientNum, sizeof( clientNum ) );
with classListArray[ serverNum, channelNum ].LockList do
try
if count > 0 then
for j := 0 to count - 1 do
begin
if TMyClass( items[ j ] ).getClientNum = clientNum then
begin
TMyClass( items[ j ] ).setLastSetTime( ticks64 ); //**********
break;
end;
end;
finally
classListArray[ serverNum, channelNum ].unLockList;
end;
end;
end
else
//.........
end;
finally
stream.free;
end;
except on e:exception do
begin
if E is Eidexception then raise
else
begin
logToFile( e.message );
//..........
end;
end;
end;
end;

According to your log, ltime was 468528329 and GetTickDiff64(ltime, Ticks64()) returned 18446744073709551600. Given the simple implementation of GetTickDiff64() (where TIdTicks is UInt64):
function GetTickDiff64(const AOldTickCount, ANewTickCount: TIdTicks): TIdTicks;
{$IFDEF USE_INLINE}inline;{$ENDIF}
begin
{This is just in case the TickCount rolled back to zero}
if ANewTickCount >= AOldTickCount then begin
Result := TIdTicks(ANewTickCount - AOldTickCount);
end else begin
Result := TIdTicks(((High(TIdTicks) - AOldTickCount) + ANewTickCount) + 1);
end;
end;
The only way this code can return 18446744073709551600 given AOldTickCount=468528329 is if ANewTickCount is either 18446744074178079929 or 468528313.
Since VCL runs on Windows only, and on Windows Ticks64() is just a thin wrapper around the Win32 GetTickCount64() function on Vista and later, it is very unlikely that Windows would ever produce such an astronomically large number like 18446744074178079929 for the current tick counter (that would be 213503982340 days from bootup). So it must have returned 468528313 instead, which is more reasonable (that is just 5.4 days from bootup). That is 16ms less than ltime=468528329, so GetTickDiff64() would assume that Windows' tick counter had exceeded High(UInt64) and wrapped back around to 0 (which is unlikely for a 64-bit tick counter to ever do in our lifetime).
So, you need to debug your code and figure out how Ticks64()/Windows could possibly return 468528329 and then later return 468528313. I suspect it is really not doing that, and that there is more likely a bug in your code that we can't see which is storing the wrong value into TMyClass.lastSetTime to begin with.
That being said, you might consider getting rid of the overhead of TCriticalSection and use TInterlocked instead to read/write your UInt64 member atomically.
Or, try using Delphi's own TStopWatch instead of tracking ticks manually.

Related

Take screenshot of a FMX form from another process, even if the form is not topmost / modal

I am currently trying to take a screenshot of a 2D Firemonkey (FMX) form from another process.
The following is using a well-known method based of GDI, using a BitBlt() to produce a bitmap, and WIC to save it to a PNG file.
{...}
uses
system.UITypes,
system.SysUtils,
system.Hash,
{$IF Defined(MSWINDOWS)}
winapi.Windows,
Winapi.Direct3D9,
WinApi.D3DX9,
Winapi.Wincodec,
WinApi.ActiveX,
{$ENDIF}
{ some internal units }
path.types,
path.utils,
os.utils;
{...}
Type
TWindowSnapshot = record
window_handle: THandle; // handle to window
process_id: Cardinal; // PID of the process
window_rect: TRect; // position of the window
title: string; // title
file_path: string; // path to the window's image file
end;
TWindowSnapshots = Tarray<TWindowSnapshot>;
procedure HRCHECK(r: HRESULT); inline;
begin
if r <> S_OK then abort;
end;
function pad(s,g:integer): integer; inline;
begin
dec(g);
result := (s + g) and not g;
end;
function WICSavePixelsToPng(r: TRect; stride: cardinal; pixels: PByte; filePath: string): HRESULT;
var
factory: IWICImagingFactory;
encoder: IWICBitmapEncoder;
frame: IWICBitmapFrameEncode;
encoderOptions: IPropertyBag2;
stream: IWICStream;
pf: TGUID;
coInit : HResult;
begin
result := E_INVALIDARG;
if not assigned(pixels) then exit;
if (filepath = '') then exit;
coInit := CoInitialize(nil);
pf := GUID_WICPixelFormat32bppBGRA;
result := CoCreateInstance(CLSID_WICImagingFactory, nil, CLSCTX_INPROC_SERVER, IWICImagingFactory, factory);
if result <> S_OK then exit;
result := factory.CreateStream(&stream);
if result <> S_OK then exit;
result := stream.InitializeFromFilename(PWideChar(filePath), GENERIC_WRITE);
if result <> S_OK then exit;
result := factory.CreateEncoder(GUID_ContainerFormatPng, TGUID.Empty, encoder);
if result <> S_OK then exit;
result := encoder.Initialize(stream, WICBitmapEncoderNoCache);
if result <> S_OK then exit;
result := encoder.CreateNewFrame(frame, encoderOptions);
if result <> S_OK then exit;
result := frame.Initialize(nil);
if result <> S_OK then exit;
result := frame.SetSize(r.width, r.height);
if result <> S_OK then exit;
result := frame.SetPixelFormat(pf);
if result <> S_OK then exit;
if pf <> GUID_WICPixelFormat32bppBGRA then
begin
assert(false,'ToDo');
end;
inc(pixels,(r.Left*4) + r.Top * stride);
result := frame.WritePixels(r.height, stride, stride * r.height, pixels);
if result <> S_OK then exit;
result := frame.Commit();
if result <> S_OK then exit;
result := encoder.Commit();
if (coInit <> 0) then
CoUninitialize();
end;
function take_window_snapshot_GDI(win_handle: THandle; PID: Cardinal; out cs: TWindowSnapshot; const image_folder: string): boolean;
var
Wr: TRect;
HdcSRC: HDC;
hDCDest: HDC;
hBmp: HBITMAP;
hOld: HGDIOBJ;
hFlags: Cardinal;
l: integer;
src_shot,dst_shot,lsrc,ldst: PByte;
sr: PRGBTriple;
dr: PRGBQuad;
buff_size: cardinal;
x,y, src_stride, dst_stride: integer;
bi: tagBITMAPINFO;
begin
result := false;
cs.window_handle := win_handle;
cs.title := '';
cs.window_rect := TRect.Empty;
cs.process_id := 0;
try
hFlags := GetWindowLong(win_handle,GWL_STYLE);
if (hFlags and (WS_DLGFRAME or WS_POPUP)) = 0 then exit;
if (hFlags and WS_VISIBLE) = 0 then exit;
GetWindowRect(win_handle,Wr);
if (Wr.Width = 0) or (Wr.Height = 0) then exit;
L := GetWindowTextLength(win_handle);
if L > 0 then
begin
setlength(cs.title,L);
GetWindowText(win_handle,pchar(cs.title),L+1);
end;
{ reserve memory for bitmaps }
src_stride := pad((wr.Width * 3),4);
dst_stride := pad((wr.Width * 4),4);
buff_size := src_stride * wr.Height;
getmem(src_shot,buff_size);
if not assigned(src_shot) then exit;
getmem(dst_shot,dst_stride * wr.Height);
if not assigned(src_shot) then
begin
freemem(src_shot);
exit;
end;
try
try
HdcSRC := GetWindowDC(win_handle);
HdcDest := CreateCompatibleDC(HdcSRC);
SetStretchBltMode(HdcDest, COLORONCOLOR);
HBmp := CreateCompatibleBitmap(HdcSRC,Wr.Width,wr.Height);
hOld := SelectObject(hDCDest,hBmp);
BitBlt(hDCDest,0,0,wr.width,wr.Height,HdcSRC,0,0,SRCCOPY);
{ target bitplane is 24 bits RGB }
bi := default(tagBITMAPINFO);
bi.bmiHeader.biSize := sizeof(TBitmapInfoHeader);
bi.bmiHeader.biWidth := wr.Width;
bi.bmiHeader.biHeight := wr.Height;
bi.bmiHeader.biPlanes := 1;
bi.bmiHeader.biBitCount := 24;
bi.bmiHeader.biCompression := BI_RGB;
GetDIBits(hDCDest,HBmp,0,wr.Height,src_shot,bi,DIB_RGB_COLORS);
{ now convert pixels to RGBA, in correct line order.
On Windows, last line is first in bitmap }
ldst := dst_shot;
lsrc := src_shot + (src_stride * wr.Height);
for y := 0 to wr.Height - 1 do
begin
dec(lsrc,src_stride);
sr := pointer(lsrc);
dr := pointer(ldst);
for x := 0 to wr.Width - 1 do
begin
dr.rgbBlue := sr.rgbtBlue;
dr.rgbRed := sr.rgbtRed;
dr.rgbGreen := sr.rgbtGreen;
dr.rgbReserved := 255;
inc(dr);
inc(sr);
end;
inc(ldst,dst_stride);
end;
{ save to PNG with WIC }
var tmp_name := Tpath.GetTempFileName('png',false,image_folder);
wr.Offset(-wr.Left,-wr.top);
if WICSavePixelsToPng(wr,dst_stride,dst_shot,tmp_name) = S_OK then
begin
result := true;
{ rename temp file name to new name if it doesn't exist already }
var new_name := Tpath.ExtractDirectory(tmp_name) + THashSHA1.GetHashStringFromFile(tmp_name) + '.png';
if not TPath.FileExists(new_name) then
begin
if Tfile.Rename(tmp_name,new_name) then
begin
cs.file_path := '';
end else begin
cs.file_path := new_name;
end;
end else begin
cs.file_path := new_name;
end;
end;
Tfile.Delete(tmp_name);
result := true;
finally
freemem(src_shot);
freemem(dst_shot);
end;
finally
SelectObject(hDCDest,hold);
DeleteDC(hDCDest);
ReleaseDC(win_handle,HdcSRC);
end;
except begin
result := false;
end;
end;
end;
This method is working for Delphi forms using VCL, however with forms using Firemonkey (FMX) 2D, it only produces bitmaps filled with BLACK (0) pixels.
I have tried an alternative using Direct3D9, that is working for Firemonkey form, however with a limitation I'll explain after the code snippet
function Take_window_snapshot_D3D(win_handle: THandle; PID: Cardinal; out cs: TWindowSnapshot; const image_folder: string): boolean;
var
D3D: IDirect3D9;
D3DDevice: IDirect3DDevice9;
mode: D3DDISPLAYMODE;
device: IDirect3DDevice9;
surface: IDirect3DSurface9;
parameters: D3DPRESENT_PARAMETERS;
rc: D3DLOCKED_RECT;
pitch: UINT;
shot: PByte;
shot_size: cardinal;
adapter: cardinal;
wr: TRect;
hCurWnd: THandle;
hCurThreadID: Cardinal;
L: integer;
hFlags: cardinal;
hr: HRESULT;
begin
result := false;
cs := default(TWindowSnapshot);
try
{ get the window type }
hFlags := GetWindowLong(win_handle,GWL_STYLE);
if (hFlags and (WS_DLGFRAME or WS_POPUP)) = 0 then exit;
if (hFlags and WS_VISIBLE) = 0 then exit;
{ size }
GetWindowRect(win_handle,Wr);
if (Wr.Width = 0) or (Wr.Height = 0) then exit;
{ title }
L := GetWindowTextLength(win_handle);
if L > 0 then
begin
setlength(cs.title,L);
GetWindowText(win_handle,pchar(cs.title),L+1);
end;
cs.window_handle := win_handle;
cs.window_rect := wr;
cs.process_id := PID;
{ Direct3D capture }
adapter := D3DADAPTER_DEFAULT;
D3D := Direct3DCreate9(D3D_SDK_VERSION);
HRCHECK(D3D.GetAdapterDisplayMode(adapter,mode));
parameters := default(D3DPRESENT_PARAMETERS);
parameters.Windowed := TRUE;
parameters.BackBufferCount := 1;
parameters.BackBufferHeight := mode.Height;
parameters.BackBufferWidth := mode.Width;
parameters.SwapEffect := D3DSWAPEFFECT_DISCARD;
parameters.hDeviceWindow := win_handle;
{ create device & capture surface }
HRCHECK(d3d.CreateDevice(adapter, D3DDEVTYPE_HAL, win_handle, D3DCREATE_SOFTWARE_VERTEXPROCESSING, #parameters, device));
{ create surface }
HRCHECK(device.CreateOffscreenPlainSurface(mode.Width, mode.Height, D3DFMT_A8R8G8B8, D3DPOOL_SYSTEMMEM, &surface, nil));
{ bring our window to front }
hCurWnd := GetForegroundWindow;
hCurThreadID := GetCurrentThreadId;
AttachThreadInput(PID,hCurThreadID,TRUE);
SetWindowPos(win_handle,HWND_TOPMOST,0,0,0,0,SWP_NOSIZE or SWP_NOMOVE);
SetWindowPos(win_handle,HWND_NOTOPMOST,0,0,0,0,SWP_SHOWWINDOW or SWP_NOSIZE or SWP_NOMOVE);
SetForegroundWindow(win_handle);
SetFocus(win_handle);
SetActiveWindow(win_handle);
AttachThreadInput(PID,hCurThreadID,false);
{ Obtain stride value to allocate buffer }
HRCHECK(surface.LockRect(rc,nil,0));
pitch := rc.Pitch;
HRCHECK(surface.UnlockRect());
shot_size := pitch*mode.Height;
getmem(shot,shot_size);
if not assigned(shot) then abort;
try
{ get surface data }
HRCHECK(device.GetFrontBufferData(0, surface));
{ copy surface data }
HRCHECK(surface.LockRect(rc,nil,0));
move(rc.pBits^,shot^,shot_size);
HRCHECK(surface.UnlockRect());
{ save snapshot to file using WIC, using a temporary file name first }
var tmp_name := Tpath.GetTempFileName('png',false,image_folder);
if WICSavePixelsToPng(wr,pitch,shot,tmp_name) = S_OK then
begin
result := true;
{ rename temp file name to new name if it doesn't exist already }
var new_name := Tpath.ExtractDirectory(tmp_name) + THashSHA1.GetHashStringFromFile(tmp_name) + '.png';
if not TPath.FileExists(new_name) then
begin
if Tfile.Rename(tmp_name,new_name) then
begin
cs.file_path := '';
end else begin
cs.file_path := new_name;
end;
end else begin
cs.file_path := new_name;
end;
end;
Tfile.Delete(tmp_name);
finally
FreeMem(shot);
end;
except
result := false;
end;
end;
The limitation that I have with the D3D method is that in reality I don't take a snapshot of a specific window but I take a snapshot of the entire screen that I crop after to take only the window of my interest.
For that, I must bring first the target window to front, but in some case this may not be possible. For instance if the target form is behind a modal form, it might be partially or totally hidden, as one can see below
So, my question : Is it possible to take a snapshot / print a single Firemonkey 2D form from another process, even if the form is not modal / partially covered by another form.
(Sorry for an answer here rather than a comment, which I can't do.)
I know little about working with different processes, but do you realise that FMX has a snapshot ability built in?
TControl.MakeScreenshot returns a bitmap of the control (with child controls). So if you can call that from the other process and return the result, that might solve your problem.
However, this won't meet your needs if you literally need the whole form including the non-client area, as a form doesn't have that method. If the contents of the form are all you need, and you have a control (e.g. a TLayout) filling the form and containing all the child controls, you could use the .MakeScreenshot of that bottom control.
And yes, .MakeScreeshot works even if something else is covering the form.

How to get the FindData structure from the IShellItem2.GetProperty output in Delphi code?

I'm enumerating the Windows shell with IShellFolder and struggle with getting the FindData structure from the TPropVariant output of IShellItem2.GetProperty so that I can explore its content.
The question is: How do I get FindData from the TPropVariant output in Delphi code? C++ snippets don't help me in this case (that's why I'm posting, because there are several around that I haven't been able translate correctly.)
What I have is:
var
ShellItem2: IShellItem2;
ppropvar: TPropVariant;
HR: HResult;
FindData: TWin32FindData;
FileSize: Int64;
if ShellItem2.GetProperty(PKEY_FindData, ppropvar) = S_OK then
begin
//It's ok, then how do I get FindData?
//Calculate the file size, for instace.
FileSize := FindData.nFileSizeLow or Int64(FindData.nFileSizeHigh) shl 32;
end;
I can't find any formal documentation about how a WIN32_FIND_DATA is stored in a PROPVARIANT. However, based on a code snippet found in this Qt code patch, the last field of the PROPVARIANT holds a pointer to a WIN32_FIND_DATAW, so try something like this:
type
PWin32FindDataW = ^TWin32FindDataW;
PPWin32FindDataW = ^PWin32FindDataW;
var
ShellItem2: IShellItem2;
ppropvar: TPropVariant;
FindData: PWin32FindDataW;
FileSize: UInt64;
begin
...
if ShellItem2.GetProperty(PKEY_FindData, ppropvar) = S_OK then begin
FindData := PPWin32FindDataW(PByte(#ppropvar) + sizeof(ppropvar) - sizeof(Pointer))^;
// alternatively:
// FindData := PWin32FindDataW(ppropvar.caub.pElems);
if FindData <> nil then begin
FileSize := FindData.nFileSizeLow or (UInt64(FindData.nFileSizeHigh) shl 32);
...
end;
PropVariantClear(ppropvar);
end;
...
end;
function GetItemFindData(AItem: IShellItem2; out AFindData: TWin32FindDataW): Boolean;
var
PV: TPropVariant;
begin
Result := False;
PV.vt := VT_EMPTY;
if AItem.GetProperty(PKEY_FindData, PV) = S_OK then
begin
if (PV.vt = VT_UI1 or VT_VECTOR) and (PV.caub.cElems = SizeOf(AFindData)) and Assigned(PV.caub.pElems) then
begin
CopyMemory(#AFindData, PV.caub.pElems, SizeOf(AFindData));
Result := True;
end;
PropVariantClear(PV);
end;
end;

Embedded CMD in Inno Setup installer (show command output on a custom page)

I created an Input page that executes a command line app using the created variables from those inputs. Naturally, the cmd window pop ups on my screen. I would like to know if there is any way to embed the cmd window (or the output) on my Inno Setup installer page.
I'm running Inno Setup 5.6.1 (because of Windows XP compatibility), but I'm OK if I have to switch to the last version.
[Code]
var
MAIL: TInputQueryWizardPage;
Final: TWizardPage;
BotonIniciar: Tbutton;
procedure BotonIniciarOnClick(Sender: TObject);
begin
WizardForm.NextButton.Onclick(nil);
Exec(ExpandConstant('{tmp}\imapsync.exe'),'MAIL.Values[0]','', SW_SHOW,
ewWaitUntilTerminated, ResultCode);
end;
procedure InitializeWizard;
begin
MAIL := CreateInputQueryPage(wpWelcome, '', '', '');
MAIL.Add('Please input your information', False);
BotonIniciar := TNewButton.Create(MAIL);
BotonIniciar.Caption := 'Iniciar';
BotonIniciar.OnClick := #BotonIniciarOnClick;
BotonIniciar.Parent := WizardForm;
BotonIniciar.Left := WizardForm.NextButton.Left - 250 ;
BotonIniciar.Top := WizardForm.CancelButton.Top - 10;
BotonIniciar.Width := WizardForm.NextButton.Width + 60;
BotonIniciar.Height := WizardForm.NextButton.Height + 10;
end;
I'm might be missing some parts of the code, but I think it's understandable.
Fist I create the input page, then I create a button with the OnClick property that calls to the BotonIniciarOnClick procedure.
Actually, the code works great. But as I said I'm having a floating cmd window.
I would like to see something like this:
It's just a random image I took from google.
What I want to see is similar to a standard "show details" option on an installer.
You can redirect the command output to a file and monitor the file for changes, loading them to list box (or maybe a memo box).
var
ProgressPage: TOutputProgressWizardPage;
ProgressListBox: TNewListBox;
function SetTimer(
Wnd: LongWord; IDEvent, Elapse: LongWord; TimerFunc: LongWord): LongWord;
external 'SetTimer#user32.dll stdcall';
function KillTimer(hWnd: LongWord; uIDEvent: LongWord): BOOL;
external 'KillTimer#user32.dll stdcall';
var
ProgressFileName: string;
function BufferToAnsi(const Buffer: string): AnsiString;
var
W: Word;
I: Integer;
begin
SetLength(Result, Length(Buffer) * 2);
for I := 1 to Length(Buffer) do
begin
W := Ord(Buffer[I]);
Result[(I * 2)] := Chr(W shr 8); { high byte }
Result[(I * 2) - 1] := Chr(Byte(W)); { low byte }
end;
end;
procedure UpdateProgress;
var
S: AnsiString;
I, L, Max: Integer;
Buffer: string;
Stream: TFileStream;
Lines: TStringList;
begin
if not FileExists(ProgressFileName) then
begin
Log(Format('Progress file %s does not exist', [ProgressFileName]));
end
else
begin
try
// Need shared read as the output file is locked for writing,
// so we cannot use LoadStringFromFile
Stream :=
TFileStream.Create(ProgressFileName, fmOpenRead or fmShareDenyNone);
try
L := Stream.Size;
Max := 100*2014;
if L > Max then
begin
Stream.Position := L - Max;
L := Max;
end;
SetLength(Buffer, (L div 2) + (L mod 2));
Stream.ReadBuffer(Buffer, L);
S := BufferToAnsi(Buffer);
finally
Stream.Free;
end;
except
Log(Format('Failed to read progress from file %s - %s', [
ProgressFileName, GetExceptionMessage]));
end;
end;
if S <> '' then
begin
Log('Progress len = ' + IntToStr(Length(S)));
Lines := TStringList.Create();
Lines.Text := S;
for I := 0 to Lines.Count - 1 do
begin
if I < ProgressListBox.Items.Count then
begin
ProgressListBox.Items[I] := Lines[I];
end
else
begin
ProgressListBox.Items.Add(Lines[I]);
end
end;
ProgressListBox.ItemIndex := ProgressListBox.Items.Count - 1;
ProgressListBox.Selected[ProgressListBox.ItemIndex] := False;
Lines.Free;
end;
// Just to pump a Windows message queue (maybe not be needed)
ProgressPage.SetProgress(0, 1);
end;
procedure UpdateProgressProc(
H: LongWord; Msg: LongWord; Event: LongWord; Time: LongWord);
begin
UpdateProgress;
end;
procedure BotonIniciarOnClick(Sender: TObject);
var
ResultCode: Integer;
Timer: LongWord;
AppPath: string;
AppError: string;
Command: string;
begin
ProgressPage :=
CreateOutputProgressPage(
'Installing something', 'Please wait until this finishes...');
ProgressPage.Show();
ProgressListBox := TNewListBox.Create(WizardForm);
ProgressListBox.Parent := ProgressPage.Surface;
ProgressListBox.Top := 0;
ProgressListBox.Left := 0;
ProgressListBox.Width := ProgressPage.SurfaceWidth;
ProgressListBox.Height := ProgressPage.SurfaceHeight;
// Fake SetProgress call in UpdateProgressProc will show it,
// make sure that user won't see it
ProgressPage.ProgressBar.Top := -100;
try
Timer := SetTimer(0, 0, 250, CreateCallback(#UpdateProgressProc));
ExtractTemporaryFile('install.bat');
AppPath := ExpandConstant('{tmp}\install.bat');
ProgressFileName := ExpandConstant('{tmp}\progress.txt');
Log(Format('Expecting progress in %s', [ProgressFileName]));
Command := Format('""%s" > "%s""', [AppPath, ProgressFileName]);
if not Exec(ExpandConstant('{cmd}'), '/c ' + Command, '', SW_HIDE,
ewWaitUntilTerminated, ResultCode) then
begin
AppError := 'Cannot start app';
end
else
if ResultCode <> 0 then
begin
AppError := Format('App failed with code %d', [ResultCode]);
end;
UpdateProgress;
finally
// Clean up
KillTimer(0, Timer);
ProgressPage.Hide;
DeleteFile(ProgressFileName);
ProgressPage.Free();
end;
if AppError <> '' then
begin
// RaiseException does not work properly while
// TOutputProgressWizardPage is shown
RaiseException(AppError);
end;
end;
Above was tested with a batch file like:
#echo off
echo Starting
echo Doing A...
echo Extracting something...
echo Doing B...
echo Extracting something...
timeout /t 1 > nul
echo Doing C...
echo Extracting something...
echo Doing D...
echo Extracting something...
timeout /t 1 > nul
echo Doing E...
echo Extracting something...
echo Doing F...
echo Extracting something...
timeout /t 1 > nul
...
If you want to display the output as part of the installation process, instead of on a button click, see:
Execute a batch file after installation and display its output on a custom page before Finished page in Inno Setup

Rewording code for better structure

program GameMain;
uses SwinGame, sgTypes;
function buttonClicked(p1, Next_PARAM_thingie: Single; W, lastOne: Integer): Boolean;
var blah, blee: Single; _r_, BTMOB: Single;
begin blah := MouseX(); blee := MouseY(); _r_ := p1 + W; BTMOB := Next_PARAM_thingie + lastOne; result := false;
if MouseClicked( LeftButton ) then
begin
if (blah >= p1) and (blah <= _r_) then
begin result := true;
end;
end;
end;
procedure Main();
var
clr: Color;
begin
OpenGraphicsWindow('Test Program for Button Click Code', 800, 600);
ShowSwinGameSplashScreen();
clr := ColorWhite;
repeat
clearScreen(clr);
drawframerate(0,0);
fillRectangle(ColorGrey, 50, 50, 100, 30);
drawtext('Click Me', ColorBlack, 'arial.ttf', 14, 55, 55);
RefreshScreen();
Processevents();
if buttonClicked(50, 50, 100, 30) then
begin
clr := RandomRGBcolor(255);
end;
until WindowCloseRequested();
end;
begin
main();
end.
I have been trying to figure out what does what but it isn't going to well. I could use some help trying to figure out what each of these random words do so I can change the name so the code is more understanding
The first thing that I would do is work through removing things that are unneeded. In the code sample given, BTMOB is entirely unused, so I would remove it and the code that sets its value. With BTMOB removed, the lastOne parameter is no longer needed, so it goes away.
Keep chipping away things that don't belong at all and using whatever context clues are available to give things that are used more meaningful names. There will be some things that you may not be able to guess just by analyzing the code and potentially not even through runtime debugging, but you should be able to make it far more readable. Here's an example of how buttonClicked might look after the first pass (you'd also have to change the code that calls it to no longer pass the unused parameters that were removed).
function buttonClicked(p1: Single; W: Integer): Boolean;
var posX: Single; _r_: Single;
begin posX := MouseX(); _r_ := p1 + W; result := false;
if MouseClicked( LeftButton ) then
begin
if (posX >= p1) and (posX <= _r_) then
begin result := true;
end;
end;
end;

Quick padding of a string in Delphi

I was trying to speed up a certain routine in an application, and my profiler, AQTime, identified one method in particular as a bottleneck. The method has been with us for years, and is part of a "misc"-unit:
function cwLeftPad(aString:string; aCharCount:integer; aChar:char): string;
var
i,vLength:integer;
begin
Result := aString;
vLength := Length(aString);
for I := (vLength + 1) to aCharCount do
Result := aChar + Result;
end;
In the part of the program that I'm optimizing at the moment the method was called ~35k times, and it took a stunning 56% of the execution time!
It's easy to see that it's a horrible way to left-pad a string, so I replaced it with
function cwLeftPad(const aString:string; aCharCount:integer; aChar:char): string;
begin
Result := StringOfChar(aChar, aCharCount-length(aString))+aString;
end;
which gave a significant boost. Total running time went from 10,2 sec to 5,4 sec. Awesome! But, cwLeftPad still accounts for about 13% of the total running time. Is there an easy way to optimize this method further?
Your new function involves three strings, the input, the result from StringOfChar, and the function result. One of them gets destroyed when your function returns. You could do it in two, with nothing getting destroyed or re-allocated.
Allocate a string of the total required length.
Fill the first portion of it with your padding character.
Fill the rest of it with the input string.
Here's an example:
function cwLeftPad(const aString: AnsiString; aCharCount: Integer; aChar: AnsiChar): AnsiString;
var
PadCount: Integer;
begin
PadCount := ACharCount - Length(AString);
if PadCount > 0 then begin
SetLength(Result, ACharCount);
FillChar(Result[1], PadCount, AChar);
Move(AString[1], Result[PadCount + 1], Length(AString));
end else
Result := AString;
end;
I don't know whether Delphi 2009 and later provide a double-byte Char-based equivalent of FillChar, and if they do, I don't know what it's called, so I have changed the signature of the function to explicitly use AnsiString. If you need WideString or UnicodeString, you'll have to find the FillChar replacement that handles two-byte characters. (FillChar has a confusing name as of Delphi 2009 since it doesn't handle full-sized Char values.)
Another thing to consider is whether you really need to call that function so often in the first place. The fastest code is the code that never runs.
Another thought - if this is Delphi 2009 or 2010, disable "String format checking" in Project, Options, Delphi Compiler, Compiling, Code Generation.
StringOfChar is very fast and I doubt you can improve this code a lot. Still, try this one, maybe it's faster:
function cwLeftPad(aString:string; aCharCount:integer; aChar:char): string;
var
i,vLength:integer;
origSize: integer;
begin
Result := aString;
origSize := Length(Result);
if aCharCount <= origSize then
Exit;
SetLength(Result, aCharCount);
Move(Result[1], Result[aCharCount-origSize+1], origSize * SizeOf(char));
for i := 1 to aCharCount - origSize do
Result[i] := aChar;
end;
EDIT: I did some testing and my function is slower than your improved cwLeftPad. But I found something else - there's no way your CPU needs 5 seconds to execute 35k cwLeftPad functions except if you're running on PC XT or formatting gigabyte strings.
I tested with this simple code
for i := 1 to 35000 do begin
a := 'abcd1234';
b := cwLeftPad(a, 73, '.');
end;
and I got 255 milliseconds for your original cwLeftPad, 8 milliseconds for your improved cwLeftPad and 16 milliseconds for my version.
You call StringOfChar every time now. Of course this method checks if it has something to do and jumps out if length is small enough, but maybe the call to StringOfChar is time consuming, because internally it does another call before jumping out.
So my first idea would be to jump out by myself if there is nothing to do:
function cwLeftPad(const aString: string; aCharCount: Integer; aChar: Char;): string;
var
l_restLength: Integer;
begin
Result := aString;
l_restLength := aCharCount - Length(aString);
if (l_restLength < 1) then
exit;
Result := StringOfChar(aChar, l_restLength) + aString;
end;
You can speed up this routine even more by using lookup array.
Of course it depends on your requirements. If you don't mind wasting some memory...
I guess that the function is called 35 k times but it has not 35000 different padding lengths and many different chars.
So if you know (or you are able to estimate in some quick way) the range of paddings and the padding chars you could build an two-dimensional array which include those parameters.
For the sake of simplicity I assume that you have 10 different padding lengths and you are padding with one character - '.', so in example it will be one-dimensional array.
You implement it like this:
type
TPaddingArray = array of String;
var
PaddingArray: TPaddingArray;
TestString: String;
function cwLeftPad4(const aString:string; const aCharCount:integer; const aChar:char; var anArray: TPaddingArray ): string;
begin
Result := anArray[aCharCount-length(aString)] + aString;
end;
begin
//fill up the array
SetLength(StrArray, 10);
PaddingArray[0] := '';
PaddingArray[1] := '.';
PaddingArray[2] := '..';
PaddingArray[3] := '...';
PaddingArray[4] := '....';
PaddingArray[5] := '.....';
PaddingArray[6] := '......';
PaddingArray[7] := '.......';
PaddingArray[8] := '........';
PaddingArray[9] := '.........';
//and you call it..
TestString := cwLeftPad4('Some string', 20, '.', PaddingArray);
end;
Here are benchmark results:
Time1 - oryginal cwLeftPad : 27,0043604142394 ms.
Time2 - your modyfication cwLeftPad : 9,25971967336897 ms.
Time3 - Rob Kennedy's version : 7,64538131122457 ms.
Time4 - cwLeftPad4 : 6,6417059620664 ms.
Updated benchmarks:
Time1 - oryginal cwLeftPad : 26,8360194218451 ms.
Time2 - your modyfication cwLeftPad : 9,69653117046119 ms.
Time3 - Rob Kennedy's version : 7,71149259179622 ms.
Time4 - cwLeftPad4 : 6,58248533610693 ms.
Time5 - JosephStyons's version : 8,76641780969192 ms.
The question is: is it worth the hassle?;-)
It's possible that it may be quicker to use StringOfChar to allocate an entirely new string the length of string and padding and then use move to copy the existing text over the back of it.
My thinking is that you create two new strings above (one with FillChar and one with the plus). This requires two memory allocates and constructions of the string pseudo-object. This will be slow. It may be quicker to waste a few CPU cycles doing some redundant filling to avoid the extra memory operations.
It may be even quicker if you allocated the memory space then did a FillChar and a Move, but the extra fn call may slow that down.
These things are often trial-and-error!
You can get dramatically better performance if you pre-allocate the string.
function cwLeftPadMine
{$IFDEF VER210} //delphi 2010
(aString: ansistring; aCharCount: integer; aChar: ansichar): ansistring;
{$ELSE}
(aString: string; aCharCount: integer; aChar: char): string;
{$ENDIF}
var
i,n,padCount: integer;
begin
padCount := aCharCount - Length(aString);
if padCount > 0 then begin
//go ahead and set Result to what it's final length will be
SetLength(Result,aCharCount);
//pre-fill with our pad character
FillChar(Result[1],aCharCount,aChar);
//begin after the padding should stop, and restore the original to the end
n := 1;
for i := padCount+1 to aCharCount do begin
Result[i] := aString[n];
end;
end
else begin
Result := aString;
end;
end;
And here is a template that is useful for doing comparisons:
procedure TForm1.btnPadTestClick(Sender: TObject);
const
c_EvalCount = 5000; //how many times will we run the test?
c_PadHowMany = 1000; //how many characters will we pad
c_PadChar = 'x'; //what is our pad character?
var
startTime, endTime, freq: Int64;
i: integer;
secondsTaken: double;
padIt: string;
begin
//store the input locally
padIt := edtPadInput.Text;
//display the results on the screen for reference
//(but we aren't testing performance, yet)
edtPadOutput.Text := cwLeftPad(padIt,c_PadHowMany,c_PadChar);
//get the frequency interval of the OS timer
QueryPerformanceFrequency(freq);
//get the time before our test begins
QueryPerformanceCounter(startTime);
//repeat the test as many times as we like
for i := 0 to c_EvalCount - 1 do begin
cwLeftPad(padIt,c_PadHowMany,c_PadChar);
end;
//get the time after the tests are done
QueryPerformanceCounter(endTime);
//translate internal time to # of seconds and display evals / second
secondsTaken := (endTime - startTime) / freq;
if secondsTaken > 0 then begin
ShowMessage('Eval/sec = ' + FormatFloat('#,###,###,###,##0',
(c_EvalCount/secondsTaken)));
end
else begin
ShowMessage('No time has passed');
end;
end;
Using that benchmark template, I get the following results:
The original: 5,000 / second
Your first revision: 2.4 million / second
My version: 3.9 million / second
Rob Kennedy's version: 3.9 million / second
This is my solution. I use StringOfChar instead of FillChar because it can handle unicode strings/characters:
function PadLeft(const Str: string; Ch: Char; Count: Integer): string;
begin
if Length(Str) < Count then
begin
Result := StringOfChar(Ch, Count);
Move(Str[1], Result[Count - Length(Str) + 1], Length(Str) * SizeOf(Char));
end
else Result := Str;
end;
function PadRight(const Str: string; Ch: Char; Count: Integer): string;
begin
if Length(Str) < Count then
begin
Result := StringOfChar(Ch, Count);
Move(Str[1], Result[1], Length(Str) * SizeOf(Char));
end
else Result := Str;
end;
It's a bit faster if you store the length of the original string in a variable:
function PadLeft(const Str: string; Ch: Char; Count: Integer): string;
var
Len: Integer;
begin
Len := Length(Str);
if Len < Count then
begin
Result := StringOfChar(Ch, Count);
Move(Str[1], Result[Count - Len + 1], Len * SizeOf(Char));
end
else Result := Str;
end;
function PadRight(const Str: string; Ch: Char; Count: Integer): string;
var
Len: Integer;
begin
Len := Length(Str);
if Len < Count then
begin
Result := StringOfChar(Ch, Count);
Move(Str[1], Result[1], Len * SizeOf(Char));
end
else Result := Str;
end;

Resources