Reimplementing time limiting of synchronous shell calls using a single shared thread

Source commit: e10cfd2641ecf3ecd25c33f89e401b1749ae5417

source/Moje.cbproj

@@ -124,6 +124,9 @@
 		<DelphiCompile Include="packages\my\NortonLikeListView.pas">
 			<BuildOrder>13</BuildOrder>
 		</DelphiCompile>
+		<DelphiCompile Include="packages\my\OperationWithTimeout.pas">
+			<BuildOrder>22</BuildOrder>
+		</DelphiCompile>
 		<DelphiCompile Include="packages\my\PasswordEdit.pas">
 			<BuildOrder>15</BuildOrder>
 		</DelphiCompile>

source/packages/dragndrop/PIDL.pas

@@ -48,8 +48,6 @@ function PIDL_GetFromParentFolder(pParentFolder: IShellFolder; pszFile: PChar):
 procedure PIDL_Free(PIDL: PItemIDList);
 function PIDL_Equal(PIDL1, PIDL2: PItemIDList): Boolean;
 
-procedure ParseDisplayNameWithTimeout(ParentFolder: IShellFolder; Path: string; var PIDL: PItemIDList);
-
 var
   ShellMalloc: IMalloc;
 
@@ -60,7 +58,7 @@ var
 implementation
 
 uses
-  SysUtils, CompThread;
+  SysUtils, CompThread, OperationWithTimeout;
 
 const NullTerm=2;
 
@@ -255,74 +253,6 @@ begin
   //piDesktopFolder._Release; -> automaticly done by D4
 end;
 
-type
-  TParseDisplayNameThread = class(TCompThread)
-  private
-    FParentFolder: IShellFolder;
-    FPath: string;
-    FPIDL: PItemIDList;
-
-  protected
-    procedure Execute; override;
-
-  public
-    constructor Create(ParentFolder: IShellFolder; Path: string);
-
-    class procedure DoIt(ParentFolder: IShellFolder; Path: string; var PIDL: PItemIDList);
-
-    property PIDL: PItemIDList read FPIDL;
-  end;
-
-constructor TParseDisplayNameThread.Create(ParentFolder: IShellFolder; Path: string);
-begin
-  inherited Create(True);
-  FParentFolder := ParentFolder;
-  FPath := Path;
-end;
-
-class procedure TParseDisplayNameThread.DoIt(ParentFolder: IShellFolder; Path: string; var PIDL: PItemIDList);
-var
-  Eaten: ULONG;
-  ShAttr: ULONG;
-begin
-  ShAttr := 0;
-  if Failed(ParentFolder.ParseDisplayName(0, nil, PChar(Path), Eaten, PIDL, ShAttr)) then
-  begin
-    PIDL := nil;
-  end;
-end;
-
-procedure TParseDisplayNameThread.Execute;
-begin
-  DoIt(FParentFolder, FPath, FPIDL);
-end;
-
-procedure ParseDisplayNameWithTimeout(ParentFolder: IShellFolder; Path: string; var PIDL: PItemIDList);
-{$IFNDEF IDE}
-var
-  Thread: TParseDisplayNameThread;
-{$ENDIF}
-begin
-  { See comment in TDriveView.GetNodeShellAttr }
-  {$IFDEF IDE}
-  TParseDisplayNameThread.DoIt(ParentFolder, Path, PIDL);
-  {$ELSE}
-  Thread := TParseDisplayNameThread.Create(ParentFolder, Path);
-  Thread.Resume;
-  if Thread.WaitFor(2 * MSecsPerSec) then
-  begin
-    PIDL := Thread.PIDL;
-    Thread.Free;
-  end
-    else
-  begin
-    // There's a chance for memory leak, if thread is terminated
-    // between WaitFor() and this line
-    Thread.FreeOnTerminate := True;
-  end;
-  {$ENDIF}
-end;
-
 function PIDL_GetFromParentFolder(pParentFolder: IShellFolder; pszFile: PChar): PItemIDList;
 //  PURPOSE:    This routine takes a Shell folder for the parent and the FileName in the folder
 //  and converts that to a relative ITEMIDLIST.
@@ -332,8 +262,11 @@ function PIDL_GetFromParentFolder(pParentFolder: IShellFolder; pszFile: PChar):
 //      pszFile       - file name in the folder.
 //  RETURN VALUE:
 //      Returns a relative ITEMIDLIST, or NULL if an error occurs.
+var
+  Eaten: ULONG;
+  ShAttr: ULONG;
 begin
-  ParseDisplayNameWithTimeout(pParentFolder, pszFile, Result);
+  ShellFolderParseDisplayNameWithTimeout(pParentFolder, 0, nil, pszFile, Eaten, Result, ShAttr, 2 * MSecsPerSec);
 end;
 
 procedure PIDL_Free(PIDL: PItemIDList);

source/packages/filemng/DirView.pas

@@ -407,7 +407,7 @@ var
 implementation
 
 uses
-  DriveView,
+  DriveView, OperationWithTimeout,
   PIDL, Forms, Dialogs,
   ShellAPI, ComObj,
   ActiveX, ImgList,
@@ -1599,36 +1599,6 @@ begin
   end;
 end; {GetAttrString}
 
-type
-  TSHGetFileInfoThread = class(TCompThread)
-  private
-    FPIDL: PItemIDList;
-    FFileAttributes: DWORD;
-    FFlags: UINT;
-    FFileInfo: TSHFileInfo;
-
-  protected
-    procedure Execute; override;
-
-  public
-    constructor Create(PIDL: PItemIDList; FileAttributes: DWORD; Flags: UINT);
-
-    property FileInfo: TSHFileInfo read FFileInfo;
-  end;
-
-constructor TSHGetFileInfoThread.Create(PIDL: PItemIDList; FileAttributes: DWORD; Flags: UINT);
-begin
-  inherited Create(True);
-  FPIDL := PIDL;
-  FFileAttributes := FileAttributes;
-  FFlags := Flags;
-end;
-
-procedure TSHGetFileInfoThread.Execute;
-begin
-  SHGetFileInfo(PChar(FPIDL), FFileAttributes, FFileInfo, SizeOf(FFileInfo), FFlags);
-end;
-
 procedure TDirView.GetDisplayData(Item: TListItem; FetchIcon: Boolean);
 var
   FileInfo: TShFileInfo;
@@ -1640,7 +1610,6 @@ var
   Eaten: ULONG;
   shAttr: ULONG;
   FileIconForName, FullName: string;
-  Thread: TSHGetFileInfoThread;
 begin
   Assert(Assigned(Item) and Assigned(Item.Data));
   with PFileRec(Item.Data)^ do
@@ -1748,20 +1717,11 @@ begin
             begin
               // Files with PIDL are typically .exe files.
               // It may take long to retrieve an icon from exe file.
-              Thread :=
-                TSHGetFileInfoThread.Create(
-                  PIDL, FILE_ATTRIBUTE_NORMAL, SHGFI_TYPENAME or SHGFI_USEFILEATTRIBUTES or SHGFI_SYSICONINDEX or SHGFI_PIDL);
-              Thread.Resume;
-              if Thread.WaitFor(MSecsPerSec div 4) then
-              begin
-                FileInfo := Thread.FileInfo;
-                Thread.Free;
-              end
-                else
+              if SHGetFileInfoForPidlWithTimeout(
+                   PIDL, FILE_ATTRIBUTE_NORMAL, FileInfo, SizeOf(FileInfo),
+                   SHGFI_TYPENAME or SHGFI_USEFILEATTRIBUTES or SHGFI_SYSICONINDEX or SHGFI_PIDL,
+                   MSecsPerSec div 4) = 0 then
               begin
-                // There's a chance for memory leak, if thread is terminated
-                // between WaitFor() and this line
-                Thread.FreeOnTerminate := True;
                 FileInfo.szTypeName[0] := #0;
                 FileInfo.iIcon := DefaultExeIcon;
               end;

source/packages/filemng/DriveView.pas

@@ -417,7 +417,7 @@ procedure Register;
 implementation
 
 uses
-  CompThread, PasTools, UITypes, Types;
+  CompThread, PasTools, UITypes, Types, OperationWithTimeout;
 
 resourcestring
    SErrorInvalidDirName = 'New name contains invalid characters %s';
@@ -1143,63 +1143,8 @@ begin
     else Result := Drive + ':';
 end; {GetDriveText}
 
-type
-  TFolderAttributesGetterThread = class(TCompThread)
-  private
-    FParentFolder: iShellFolder;
-    FPIDL: PItemIDList;
-    FshAttr: UINT;
-
-  protected
-    procedure Execute; override;
-
-  public
-    constructor Create(ParentFolder: iShellFolder; PIDL: PItemIDList; shAttr: UINT);
-
-    property shAttr: UINT read FshAttr;
-
-    class procedure GetFolderAttributes(ParentFolder: iShellFolder; PIDL: PItemIDList; var shAttr: UINT);
-  end;
-
-class procedure TFolderAttributesGetterThread.GetFolderAttributes(
-  ParentFolder: iShellFolder; PIDL: PItemIDList; var shAttr: UINT);
-var
-  NotResult: Boolean;
-  ErrorMode: Word;
-begin
-  ErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS or SEM_NOOPENFILEERRORBOX);
-  try
-    try
-      NotResult := not Succeeded(ParentFolder.GetAttributesOf(1, PIDL, shAttr));
-    finally
-      SetErrorMode(ErrorMode);
-    end;
-    if NotResult then shAttr := 0;
-  except
-    shAttr := 0;
-  end;
-end;
-
-constructor TFolderAttributesGetterThread.Create(ParentFolder: iShellFolder; PIDL: PItemIDList; shAttr: UINT);
-begin
-  inherited Create(True);
-  FParentFolder := ParentFolder;
-  FPIDL := PIDL;
-  FshAttr := shAttr;
-end;
-
-procedure TFolderAttributesGetterThread.Execute;
-begin
-  GetFolderAttributes(FParentFolder, FPIDL, FshAttr);
-end;
-
 procedure TDriveView.GetNodeShellAttr(ParentFolder: IShellFolder;
   NodeData: TNodeData; Path: string; ContentMask: Boolean = True);
-var
-{$IFNDEF IDE}
-  Thread: TFolderAttributesGetterThread;
-{$ENDIF}
-  shAttr: ULONG;
 begin
   if (not Assigned(ParentFolder)) or (not Assigned(NodeData)) then
     Exit;
@@ -1209,33 +1154,14 @@ begin
   if Assigned(NodeData.PIDL) then
   begin
     if ContentMask then
-      shAttr := SFGAO_DISPLAYATTRMASK or SFGAO_CONTENTSMASK
+      NodeData.shAttr := SFGAO_DISPLAYATTRMASK or SFGAO_CONTENTSMASK
     else
-      shAttr := SFGAO_DISPLAYATTRMASK;
-
-    // Resoving attributes may take ages, so we run it from a separate thread
-    // and timeout waiting for the thread after a second.
-    // But when running from IDE, it triggers starting/exiting the thread,
-    // again taking ages. So in IDE we revert to single-thread approach
-    {$IFDEF IDE}
-    TFolderAttributesGetterThread.GetFolderAttributes(ParentFolder, NodeData.PIDL, shAttr);
-    NodeData.shAttr := shAttr;
-    {$ELSE}
-    Thread := TFolderAttributesGetterThread.Create(ParentFolder, NodeData.PIDL, shAttr);
-    Thread.Resume;
-    if Thread.WaitFor(MSecsPerSec) then
-    begin
-      NodeData.shAttr := Thread.shAttr;
-      Thread.Free;
-    end
-      else
+      NodeData.shAttr := SFGAO_DISPLAYATTRMASK;
+
+    if not Succeeded(ShellFolderGetAttributesOfWithTimeout(ParentFolder, 1, NodeData.PIDL, NodeData.shAttr, MSecsPerSec)) then
     begin
-      // There's a chance for memory leak, if thread is terminated
-      // between WaitFor() and this line
-      Thread.FreeOnTerminate := True;
       NodeData.shAttr := 0;
     end;
-    {$ENDIF}
 
     if not ContentMask then
       NodeData.shAttr := NodeData.shAttr or SFGAO_HASSUBFOLDER;

source/packages/filemng/IEDriveInfo.pas

@@ -113,7 +113,7 @@ resourceString
 implementation
 
 uses
-  Math, PIDL;
+  Math, PIDL, OperationWithTimeout;
 
 constructor TDriveInfo.Create;
 begin
@@ -327,13 +327,14 @@ begin
     begin
       if (not Assigned(PIDL)) and (Drive >= FirstFixedDrive) then
       begin
+        ShAttr := 0;
         if DriveType = DRIVE_REMOTE then
         begin
-          ParseDisplayNameWithTimeout(FDesktop, Drive + ':\', PIDL);
+          ShellFolderParseDisplayNameWithTimeout(
+            FDesktop, Application.Handle, nil, PChar(Drive + ':\'), Eaten, PIDL, ShAttr, 2 * MSecsPerSec);
         end
           else
         begin
-          ShAttr := 0;
           FDesktop.ParseDisplayName(Application.Handle, nil, PChar(Drive + ':\'), Eaten, PIDL, ShAttr);
         end;
       end;

source/packages/my/OperationWithTimeout.pas

@@ -0,0 +1,311 @@
+unit OperationWithTimeout;
+
+interface
+
+uses
+  Winapi.Windows, Winapi.ShlObj, Winapi.ShellAPI, ActiveX;
+
+function ShellFolderGetAttributesOfWithTimeout(
+  ShellFolder: IShellFolder; cidl: UINT; var apidl: PItemIDList; var rgfInOut: UINT; Timeout: Integer): HResult;
+
+function SHGetFileInfoForPidlWithTimeout(
+  PIDL: PItemIDList; dwFileAttributes: DWORD; var psfi: TSHFileInfoW;
+  cbFileInfo, uFlags: UINT; Timeout: Integer): DWORD_PTR;
+
+function ShellFolderParseDisplayNameWithTimeout(
+  ShellFolder: IShellFolder; hwndOwner: HWND; pbcReserved: Pointer; lpszDisplayName: POLESTR;
+  out pchEaten: ULONG; out ppidl: PItemIDList; var dwAttributes: ULONG; Timeout: Integer): HResult;
+
+implementation
+
+uses
+  System.Classes, System.Types, System.SysUtils, System.SyncObjs, System.Contnrs, CompThread;
+
+type
+  TOperation = class;
+
+  TOperationEvent = procedure(Operation: TOperation);
+
+  TOperation = class(TObject)
+  public
+    OperationEvent: TOperationEvent;
+
+    // ShellFolderGetAttributesOfWithTimeout
+    ShellFolder: IShellFolder;
+    cidl: UINT;
+    apidl: PItemIDList;
+    rgfInOut: UINT;
+    Timeout: Integer;
+    ResultHResult: HResult;
+
+    // SHGetFileInfoWithTimeout
+    PIDL: PItemIDList;
+    dwFileAttributes: DWORD;
+    psfi: TSHFileInfoW;
+    cbFileInfo, uFlags: UINT;
+    ResultDWordPtr: DWORD_PTR;
+
+    // ShellFolderParseDisplayNameWithTimeout
+    // Uses ShellFolder and ResultHResult
+    hwndOwner: HWND;
+    pbcReserved: Pointer;
+    DisplayName: string;
+    pchEaten: ULONG;
+    ppidl: PItemIDList;
+    dwAttributes: ULONG;
+
+    constructor Create(AOperationEvent: TOperationEvent);
+  end;
+
+constructor TOperation.Create(AOperationEvent: TOperationEvent);
+begin
+  OperationEvent := AOperationEvent;
+end;
+
+type
+  TOperationWithTimeoutThread = class(TCompThread)
+  public
+    constructor Create;
+    destructor Destroy; override;
+    procedure Terminate; override;
+
+    procedure Queue(Operation: TOperation);
+    function WaitForOperation(Milliseconds: Cardinal): Boolean;
+    procedure Remove(Operation: TOperation);
+
+  protected
+    procedure Execute; override;
+
+  private
+    FCriticalSection: TCriticalSection;
+    FRequestEvent: THandle;
+    FResultEvent: THandle;
+    FQueue: TObjectList;
+    FResults: TObjectList;
+  end;
+
+constructor TOperationWithTimeoutThread.Create;
+begin
+  inherited Create(True);
+  FRequestEvent := CreateEvent(nil, False, False, nil);
+  FResultEvent := CreateEvent(nil, False, False, nil);
+  FCriticalSection := TCriticalSection.Create;
+  FQueue := TObjectList.Create;
+  FResults := TObjectList.Create;
+  Resume;
+end;
+
+destructor TOperationWithTimeoutThread.Destroy;
+begin
+  inherited;
+  FQueue.Free;
+  FResults.Free;
+  FCriticalSection.Free;
+  CloseHandle(FRequestEvent);
+  CloseHandle(FResultEvent);
+end;
+
+procedure TOperationWithTimeoutThread.Terminate;
+begin
+  inherited;
+  SetEvent(FRequestEvent);
+end;
+
+procedure TOperationWithTimeoutThread.Execute;
+var
+  Operation: TOperation;
+begin
+  while WaitForSingleObject(FRequestEvent, INFINITE) = WAIT_OBJECT_0 do
+  begin
+    if Terminated then
+    begin
+      break;
+    end
+      else
+    begin
+      FCriticalSection.Enter;
+      try
+        Operation := TOperation(FQueue[0]);
+        FQueue.Extract(Operation);
+      finally
+        FCriticalSection.Leave;
+      end;
+
+      Operation.OperationEvent(Operation);
+      FResults.Add(Operation);
+      SetEvent(FResultEvent);
+    end;
+  end;
+end;
+
+procedure TOperationWithTimeoutThread.Queue(Operation: TOperation);
+begin
+  FCriticalSection.Enter;
+  try
+    FQueue.Add(Operation);
+  finally
+    FCriticalSection.Leave;
+  end;
+
+  SetEvent(FRequestEvent);
+end;
+
+function TOperationWithTimeoutThread.WaitForOperation(Milliseconds: Cardinal): Boolean;
+begin
+  ResetEvent(FResultEvent);
+  Result := (WaitForSingleObject(FResultEvent, Milliseconds) = WAIT_OBJECT_0);
+end;
+
+procedure TOperationWithTimeoutThread.Remove(Operation: TOperation);
+begin
+  FCriticalSection.Enter;
+  try
+    FResults.Remove(Operation);
+  finally
+    FCriticalSection.Leave;
+  end;
+end;
+
+var
+  Thread: TOperationWithTimeoutThread = nil;
+
+procedure NeedThread;
+begin
+  if not Assigned(Thread) then
+  begin
+    Thread := TOperationWithTimeoutThread.Create;
+  end;
+end;
+
+function WaitForOperation(Milliseconds: Cardinal): Boolean;
+begin
+  Result := Thread.WaitForOperation(Milliseconds);
+  if not Result then
+  begin
+    // There's a chance for memory leak, if thread is terminated
+    // between WaitFor() and this line
+    Thread.FreeOnTerminate := True;
+    Thread.Terminate;
+    Thread := nil;
+  end;
+end;
+
+procedure ShellFolderGetAttributesOfOperation(Operation: TOperation);
+var
+  ErrorMode: Word;
+begin
+  ErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS or SEM_NOOPENFILEERRORBOX);
+  try
+    Operation.ResultHResult := Operation.ShellFolder.GetAttributesOf(Operation.cidl, Operation.apidl, Operation.rgfInOut);
+  except
+    Operation.ResultHResult := E_FAIL;
+  end;
+  SetErrorMode(ErrorMode);
+end;
+
+function ShellFolderGetAttributesOfWithTimeout(
+  ShellFolder: IShellFolder; cidl: UINT; var apidl: PItemIDList; var rgfInOut: UINT; Timeout: Integer): HResult;
+var
+  Operation: TOperation;
+begin
+  NeedThread;
+  Operation := TOperation.Create(ShellFolderGetAttributesOfOperation);
+  Operation.ShellFolder := ShellFolder;
+  Operation.cidl := cidl;
+  Operation.apidl := apidl;
+  Operation.rgfInOut := rgfInOut;
+  Thread.Queue(Operation);
+  if WaitForOperation(Timeout) then
+  begin
+    apidl := Operation.apidl;
+    rgfInOut := Operation.rgfInOut;
+    Result := Operation.ResultHResult;
+    Thread.Remove(Operation);
+  end
+    else
+  begin
+    rgfInOut := 0;
+    Result := E_FAIL;
+  end;
+end;
+
+procedure SHGetFileInfoForPidlOperation(Operation: TOperation);
+begin
+  Operation.ResultDWordPtr :=
+    SHGetFileInfo(PChar(Operation.PIDL), Operation.dwFileAttributes, Operation.psfi, Operation.cbFileInfo, Operation.uFlags);
+end;
+
+function SHGetFileInfoForPidlWithTimeout(
+  PIDL: PItemIDList; dwFileAttributes: DWORD; var psfi: TSHFileInfoW;
+  cbFileInfo, uFlags: UINT; Timeout: Integer): DWORD_PTR;
+var
+  Operation: TOperation;
+begin
+  NeedThread;
+  Operation := TOperation.Create(SHGetFileInfoForPidlOperation);
+  Operation.PIDL := PIDL;
+  Operation.dwFileAttributes := dwFileAttributes;
+  Operation.psfi := psfi;
+  Operation.cbFileInfo := cbFileInfo;
+  Operation.uFlags := uFlags;
+  Thread.Queue(Operation);
+  if WaitForOperation(Timeout) then
+  begin
+    psfi := Operation.psfi;
+    Result := Operation.ResultDWordPtr;
+    Thread.Remove(Operation);
+  end
+    else
+  begin
+    FillChar(psfi, SizeOf(psfi), 0);
+    Result := 0;
+  end;
+end;
+
+procedure ShellFolderParseDisplayNameOperation(Operation: TOperation);
+begin
+  Operation.ResultHResult :=
+    Operation.ShellFolder.ParseDisplayName(
+      Operation.hwndOwner, Operation.pbcReserved, PChar(Operation.DisplayName),
+      Operation.pchEaten, Operation.ppidl, Operation.dwAttributes);
+end;
+
+function ShellFolderParseDisplayNameWithTimeout(
+  ShellFolder: IShellFolder; hwndOwner: HWND; pbcReserved: Pointer; lpszDisplayName: POLESTR; out pchEaten: ULONG;
+  out ppidl: PItemIDList; var dwAttributes: ULONG; Timeout: Integer): HResult;
+var
+  Operation: TOperation;
+begin
+  NeedThread;
+  Operation := TOperation.Create(ShellFolderParseDisplayNameOperation);
+  Operation.ShellFolder := ShellFolder;
+  Operation.hwndOwner := hwndOwner;
+  Operation.pbcReserved := pbcReserved;
+  Operation.DisplayName := lpszDisplayName;
+  Operation.pchEaten := 0;
+  Operation.ppidl := nil;
+  Operation.dwAttributes := 0;
+  Thread.Queue(Operation);
+  if WaitForOperation(Timeout) then
+  begin
+    ppidl := Operation.ppidl;
+    dwAttributes := Operation.dwAttributes;
+    Result := Operation.ResultHResult;
+    Thread.Remove(Operation);
+  end
+    else
+  begin
+    ppidl := nil;
+    dwAttributes := 0;
+    Result := E_FAIL;
+  end;
+end;
+
+initialization
+
+finalization
+  if Assigned(Thread) then
+  begin
+    Thread.Free;
+  end;
+end.