OperationWithTimeout.pas 6.8 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243
  1. unit OperationWithTimeout;
  2. interface
  3. uses
  4. Winapi.Windows, Winapi.ShlObj, Winapi.ShellAPI, ActiveX;
  5. function SHGetFileInfoWithTimeout(
  6. pszPath: LPCWSTR; dwFileAttributes: DWORD; var psfi: TSHFileInfoW;
  7. cbFileInfo, uFlags: UINT; Timeout: Integer): DWORD_PTR;
  8. function ShellFolderParseDisplayNameWithTimeout(
  9. ShellFolder: IShellFolder; hwndOwner: HWND; pbcReserved: Pointer; lpszDisplayName: POLESTR;
  10. out pchEaten: ULONG; out ppidl: PItemIDList; var dwAttributes: ULONG; Timeout: Integer): HResult;
  11. function DestinationListBeginList(
  12. DestinationList: ICustomDestinationList; var pcMaxSlots: UINT; const riid: TIID; out ppv: Pointer; Timeout: Integer): HRESULT;
  13. var
  14. TimeoutShellOperations: Boolean = True;
  15. implementation
  16. uses
  17. System.Classes, System.Types, System.SysUtils, CompThread;
  18. type
  19. TOperation = class;
  20. TOperationEvent = procedure(Operation: TOperation);
  21. TOperation = class(TObject)
  22. public
  23. // SHGetFileInfoWithTimeout
  24. PIDL: PItemIDList;
  25. Path: string;
  26. dwFileAttributes: DWORD;
  27. psfi: TSHFileInfoW;
  28. cbFileInfo, uFlags: UINT;
  29. ResultDWordPtr: DWORD_PTR;
  30. // ShellFolderParseDisplayNameWithTimeout
  31. ShellFolder: IShellFolder;
  32. ResultHResult: HResult;
  33. hwndOwner: HWND;
  34. pbcReserved: Pointer;
  35. DisplayName: string;
  36. pchEaten: ULONG;
  37. ppidl: PItemIDList;
  38. dwAttributes: ULONG;
  39. // DestinationListBeginList uses ResultHResult
  40. DestinationList: ICustomDestinationList;
  41. pcMaxSlots: UINT;
  42. riid: TIID;
  43. ppv: Pointer;
  44. end;
  45. type
  46. TOperationWithTimeoutThread = class(TCompThread)
  47. public
  48. constructor Create(Operation: TOperation; OperationEvent: TOperationEvent);
  49. protected
  50. procedure Execute; override;
  51. private
  52. FOperation: TOperation;
  53. FOperationEvent: TOperationEvent;
  54. end;
  55. constructor TOperationWithTimeoutThread.Create(Operation: TOperation; OperationEvent: TOperationEvent);
  56. begin
  57. inherited Create(True);
  58. FOperation := Operation;
  59. FOperationEvent := OperationEvent;
  60. end;
  61. procedure TOperationWithTimeoutThread.Execute;
  62. begin
  63. // Needed for various API, particularly:
  64. // - SHGetFileInfo fails to return icon index on some systems;
  65. // - ICustomDestinationList.BeginList returns invalid "removed" array.
  66. CoInitialize(nil);
  67. FOperationEvent(FOperation);
  68. end;
  69. function WaitForOperation(
  70. Operation: TOperation; OperationEvent: TOperationEvent; Milliseconds: Cardinal): Boolean;
  71. {$IFNDEF IDE}
  72. var
  73. Thread: TOperationWithTimeoutThread;
  74. {$ENDIF}
  75. begin
  76. // When running from IDE, it triggers starting/exiting the thread taking ages.
  77. // So in IDE we revert to single-thread approach.
  78. {$IFNDEF IDE}
  79. if not TimeoutShellOperations then
  80. {$ENDIF}
  81. begin
  82. OperationEvent(Operation);
  83. Result := True;
  84. end
  85. {$IFNDEF IDE}
  86. else
  87. begin
  88. // Have to start new thread for each request. When shared thread is used, it eventually hangs.
  89. // Most probably do to the fact that we violate COM threading model.
  90. // So using a new thread for each request, is only a hack that happens to work by pure luck.
  91. // We may want to use shared thread at least for COM-free operations, like SHGetFileInfo.
  92. Thread := TOperationWithTimeoutThread.Create(Operation, OperationEvent);
  93. Thread.Resume;
  94. Result := Thread.WaitFor(MSecsPerSec);
  95. if Result then
  96. begin
  97. Thread.Free;
  98. end
  99. else
  100. begin
  101. // There's a chance for memory leak, if thread is terminated
  102. // between WaitFor() and this line
  103. Thread.FreeOnTerminate := True;
  104. end;
  105. end;
  106. {$ENDIF}
  107. end;
  108. procedure SHGetFileInfoOperation(Operation: TOperation);
  109. var
  110. pszPath: LPCWSTR;
  111. begin
  112. if Operation.uFlags and SHGFI_PIDL <> 0 then
  113. begin
  114. pszPath := LPCWSTR(Operation.PIDL);
  115. end
  116. else
  117. begin
  118. pszPath := LPCWSTR(Operation.Path);
  119. end;
  120. Operation.ResultDWordPtr :=
  121. SHGetFileInfo(pszPath, Operation.dwFileAttributes, Operation.psfi, Operation.cbFileInfo, Operation.uFlags);
  122. end;
  123. function SHGetFileInfoWithTimeout(
  124. pszPath: LPCWSTR; dwFileAttributes: DWORD; var psfi: TSHFileInfoW;
  125. cbFileInfo, uFlags: UINT; Timeout: Integer): DWORD_PTR;
  126. var
  127. Operation: TOperation;
  128. begin
  129. Operation := TOperation.Create;
  130. if uFlags and SHGFI_PIDL <> 0 then
  131. begin
  132. Operation.PIDL := PItemIDList(pszPath);
  133. end
  134. else
  135. begin
  136. Operation.Path := pszPath;
  137. end;
  138. Operation.dwFileAttributes := dwFileAttributes;
  139. Operation.psfi := psfi;
  140. Operation.cbFileInfo := cbFileInfo;
  141. Operation.uFlags := uFlags;
  142. if WaitForOperation(Operation, SHGetFileInfoOperation, Timeout) then
  143. begin
  144. psfi := Operation.psfi;
  145. Result := Operation.ResultDWordPtr;
  146. Operation.Free;
  147. end
  148. else
  149. begin
  150. FillChar(psfi, SizeOf(psfi), 0);
  151. Result := 0;
  152. end;
  153. end;
  154. procedure ShellFolderParseDisplayNameOperation(Operation: TOperation);
  155. begin
  156. Operation.ResultHResult :=
  157. Operation.ShellFolder.ParseDisplayName(
  158. Operation.hwndOwner, Operation.pbcReserved, PChar(Operation.DisplayName),
  159. Operation.pchEaten, Operation.ppidl, Operation.dwAttributes);
  160. end;
  161. function ShellFolderParseDisplayNameWithTimeout(
  162. ShellFolder: IShellFolder; hwndOwner: HWND; pbcReserved: Pointer; lpszDisplayName: POLESTR; out pchEaten: ULONG;
  163. out ppidl: PItemIDList; var dwAttributes: ULONG; Timeout: Integer): HResult;
  164. var
  165. Operation: TOperation;
  166. begin
  167. Operation := TOperation.Create;
  168. Operation.ShellFolder := ShellFolder;
  169. Operation.hwndOwner := hwndOwner;
  170. Operation.pbcReserved := pbcReserved;
  171. Operation.DisplayName := lpszDisplayName;
  172. Operation.pchEaten := 0;
  173. Operation.ppidl := nil;
  174. Operation.dwAttributes := 0;
  175. if WaitForOperation(Operation, ShellFolderParseDisplayNameOperation, Timeout) then
  176. begin
  177. ppidl := Operation.ppidl;
  178. dwAttributes := Operation.dwAttributes;
  179. Result := Operation.ResultHResult;
  180. Operation.Free;
  181. end
  182. else
  183. begin
  184. ppidl := nil;
  185. dwAttributes := 0;
  186. Result := E_FAIL;
  187. end;
  188. end;
  189. procedure DestinationListBeginListOperation(Operation: TOperation);
  190. begin
  191. Operation.ResultHResult := Operation.DestinationList.BeginList(Operation.pcMaxSlots, Operation.riid, Operation.ppv);
  192. end;
  193. function DestinationListBeginList(
  194. DestinationList: ICustomDestinationList; var pcMaxSlots: UINT; const riid: TIID; out ppv: Pointer; Timeout: Integer): HRESULT;
  195. var
  196. Operation: TOperation;
  197. begin
  198. Operation := TOperation.Create;
  199. Operation.DestinationList := DestinationList;
  200. Operation.pcMaxSlots := pcMaxSlots;
  201. Operation.riid := riid;
  202. Operation.ppv := ppv;
  203. if WaitForOperation(Operation, DestinationListBeginListOperation, Timeout) then
  204. begin
  205. pcMaxSlots := Operation.pcMaxSlots;
  206. ppv := Operation.ppv;
  207. Result := Operation.ResultHResult;
  208. Operation.Free;
  209. end
  210. else
  211. begin
  212. ppv := nil;
  213. Result := E_FAIL;
  214. end;
  215. end;
  216. end.