sysutils.inc 18 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756
  1. {
  2. This file is part of the Free Pascal run time library.
  3. Copyright (c) 1999-2000 by Florian Klaempfl
  4. member of the Free Pascal development team
  5. See the file COPYING.FPC, included in this distribution,
  6. for details about the copyright.
  7. This program is distributed in the hope that it will be useful,
  8. but WITHOUT ANY WARRANTY; without even the implied warranty of
  9. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  10. **********************************************************************}
  11. { Read filename handling functions implementation }
  12. {$i fina.inc}
  13. { variant error codes }
  14. {$i varerror.inc}
  15. Function FileSearch (Const Name, DirList : String; Options : TFileSearchoptions = [sfoImplicitCurrentDir]) : String;
  16. Var
  17. I : longint;
  18. Temp : String;
  19. begin
  20. Result:=Name;
  21. temp:=SetDirSeparators(DirList);
  22. // Start with checking the file in the current directory
  23. If (sfoImplicitCurrentDir in Options) and (Result <> '') and FileExists(Result) Then
  24. exit;
  25. while True do begin
  26. If Temp = '' then
  27. Break; // No more directories to search - fail
  28. I:=pos(PathSeparator,Temp);
  29. If I<>0 then
  30. begin
  31. Result:=Copy (Temp,1,i-1);
  32. system.Delete(Temp,1,I);
  33. end
  34. else
  35. begin
  36. Result:=Temp;
  37. Temp:='';
  38. end;
  39. If Result<>'' then
  40. begin
  41. If (sfoStripQuotes in Options) and (Result[1]='"') and (Result[Length(Result)]='"') then
  42. Result:=Copy(Result,2,Length(Result)-2);
  43. if (Result<>'') then
  44. Result:=IncludeTrailingPathDelimiter(Result)+name;
  45. end;
  46. If (Result <> '') and FileExists(Result) Then
  47. exit;
  48. end;
  49. result:='';
  50. end;
  51. Function FileSearch (Const Name, DirList : String; ImplicitCurrentDir : Boolean) : String;
  52. begin
  53. if ImplicitCurrentDir then
  54. Result:=FileSearch(Name,DirList,[sfoImplicitCurrentDir])
  55. else
  56. Result:=FileSearch(Name,DirList,[]);
  57. end;
  58. Function ExeSearch (Const Name : String; Const DirList : String ='' ) : String;
  59. Var
  60. D : String;
  61. O : TFileSearchOptions;
  62. begin
  63. D:=DirList;
  64. if (D='') then
  65. D:=GetEnvironmentVariable('PATH');
  66. {$ifdef unix}
  67. O:=[];
  68. {$else unix}
  69. O:=[sfoImplicitCurrentDir,sfoStripQuotes];
  70. {$endif unix}
  71. Result := FileSearch(Name, D, O);
  72. end;
  73. {$ifndef OS_FILEISREADONLY}
  74. Function FileIsReadOnly(const FileName: String): Boolean;
  75. begin
  76. Result := (FileGetAttr(FileName) and faReadOnly) <> 0;
  77. end;
  78. {$endif OS_FILEISREADONLY}
  79. {$ifndef OS_FILESETDATEBYNAME}
  80. Function FileSetDate (Const FileName : String;Age : Longint) : Longint;
  81. Var
  82. fd : THandle;
  83. begin
  84. { at least windows requires fmOpenWrite here }
  85. fd:=FileOpen(FileName,fmOpenWrite);
  86. If (Fd<>feInvalidHandle) then
  87. try
  88. Result:=FileSetDate(fd,Age);
  89. finally
  90. FileClose(fd);
  91. end
  92. else
  93. {$ifdef HAS_OSERROR}
  94. Result:=GetLastOSError;
  95. {$else}
  96. Result:=-1;
  97. {$endif}
  98. end;
  99. {$endif}
  100. { Read String Handling functions implementation }
  101. {$i sysstr.inc}
  102. { Read date & Time function implementations }
  103. {$ifndef FPUNONE}
  104. {$i dati.inc}
  105. {$endif}
  106. { Read pchar handling functions implementation }
  107. {$i syspch.inc}
  108. { generic internationalisation code }
  109. {$i sysint.inc}
  110. { MCBS functions }
  111. {$i sysansi.inc}
  112. {$i syscodepages.inc}
  113. { wide string functions }
  114. {$i syswide.inc}
  115. {$ifdef FPC_HAS_UNICODESTRING}
  116. { unicode string functions }
  117. {$i sysuni.inc}
  118. {$i sysencoding.inc}
  119. {$endif FPC_HAS_UNICODESTRING}
  120. { threading stuff }
  121. {$i sysuthrd.inc}
  122. { OS utility code }
  123. {$i osutil.inc}
  124. procedure FreeAndNil(var obj);
  125. var
  126. temp: tobject;
  127. begin
  128. temp:=tobject(obj);
  129. pointer(obj):=nil;
  130. temp.free;
  131. end;
  132. { Interfaces support }
  133. {$i sysuintf.inc}
  134. constructor Exception.Create(const msg : string);
  135. begin
  136. inherited create;
  137. fmessage:=msg;
  138. end;
  139. constructor Exception.CreateFmt(const msg : string; const args : array of const);
  140. begin
  141. inherited create;
  142. fmessage:=Format(msg,args);
  143. end;
  144. constructor Exception.CreateRes(ResString: PString);
  145. begin
  146. inherited create;
  147. fmessage:=ResString^;
  148. end;
  149. constructor Exception.CreateResFmt(ResString: PString; const Args: array of const);
  150. begin
  151. inherited create;
  152. fmessage:=Format(ResString^,args);
  153. end;
  154. constructor Exception.CreateHelp(const Msg: string; AHelpContext: Integer);
  155. begin
  156. inherited create;
  157. fmessage:=Msg;
  158. fhelpcontext:=AHelpContext;
  159. end;
  160. constructor Exception.CreateFmtHelp(const Msg: string; const Args: array of const;
  161. AHelpContext: Integer);
  162. begin
  163. inherited create;
  164. fmessage:=Format(Msg,args);
  165. fhelpcontext:=AHelpContext;
  166. end;
  167. constructor Exception.CreateResHelp(ResString: PString; AHelpContext: Integer);
  168. begin
  169. inherited create;
  170. fmessage:=ResString^;
  171. fhelpcontext:=AHelpContext;
  172. end;
  173. constructor Exception.CreateResFmtHelp(ResString: PString; const Args: array of const;
  174. AHelpContext: Integer);
  175. begin
  176. inherited create;
  177. fmessage:=Format(ResString^,args);
  178. fhelpcontext:=AHelpContext;
  179. end;
  180. procedure EHeapMemoryError.FreeInstance;
  181. begin
  182. if AllowFree then
  183. inherited FreeInstance;
  184. end;
  185. Constructor EVariantError.CreateCode (Code : longint);
  186. begin
  187. case Code of
  188. VAR_OK:
  189. Create(SNoError);
  190. VAR_PARAMNOTFOUND:
  191. Create(SVarParamNotFound);
  192. VAR_TYPEMISMATCH:
  193. Create(SInvalidVarCast);
  194. VAR_BADVARTYPE:
  195. Create(SVarBadType);
  196. VAR_OVERFLOW:
  197. Create(SVarOverflow);
  198. VAR_BADINDEX:
  199. Create(SVarArrayBounds);
  200. VAR_ARRAYISLOCKED:
  201. Create(SVarArrayLocked);
  202. VAR_NOTIMPL:
  203. Create(SVarNotImplemented);
  204. VAR_OUTOFMEMORY:
  205. Create(SVarOutOfMemory);
  206. VAR_INVALIDARG:
  207. Create(SVarInvalid);
  208. VAR_UNEXPECTED,
  209. VAR_EXCEPTION:
  210. Create(SVarUnexpected);
  211. else
  212. CreateFmt(SUnknownErrorCode,[Code]);
  213. end;
  214. ErrCode:=Code;
  215. end;
  216. {$ifdef windows}
  217. function EExternal.GetExceptionRecord: PExceptionRecord;
  218. begin
  219. result:=@FExceptionRecord;
  220. end;
  221. {$endif windows}
  222. {$push}
  223. {$S-}
  224. Procedure CatchUnhandledException (Obj : TObject; Addr: Pointer; FrameCount: Longint; Frames: PPointer);[public,alias:'FPC_BREAK_UNHANDLED_EXCEPTION'];
  225. Var
  226. i : longint;
  227. hstdout : ^text;
  228. begin
  229. hstdout:=@stdout;
  230. Writeln(hstdout^,'An unhandled exception occurred at $',HexStr(Addr),':');
  231. if Obj is exception then
  232. Writeln(hstdout^,Obj.ClassName,': ',Exception(Obj).Message)
  233. else
  234. Writeln(hstdout^,'Exception object ',Obj.ClassName,' is not of class Exception.');
  235. Writeln(hstdout^,BackTraceStrFunc(Addr));
  236. if (FrameCount>0) then
  237. begin
  238. for i:=0 to FrameCount-1 do
  239. Writeln(hstdout^,BackTraceStrFunc(Frames[i]));
  240. end;
  241. Writeln(hstdout^,'');
  242. end;
  243. type
  244. PExceptMapEntry=^TExceptMapEntry;
  245. TExceptMapEntry=record
  246. code: byte;
  247. cls: ExceptClass;
  248. {$IFDEF FPC_HAS_FEATURE_RESOURCES} // This is necessary for 2.4.4, which does not have reasources as a separate feature
  249. msg: PResStringRec;
  250. {$else FPC_HAS_FEATURE_RESOURCES}
  251. msg: PString;
  252. {$endif FPC_HAS_FEATURE_RESOURCES}
  253. end;
  254. const
  255. exceptmap: array[0..27] of TExceptMapEntry = (
  256. (code: 200; cls: EDivByZero; msg: @SDivByZero),
  257. (code: 201; cls: ERangeError; msg: @SRangeError),
  258. (code: 202; cls: EStackOverflow; msg: @SStackOverflow),
  259. (code: 205; cls: EOverflow; msg: @SOverflow),
  260. (code: 206; cls: EUnderflow; msg: @SUnderflow),
  261. (code: 207; cls: EInvalidOp; msg: @SInvalidOp),
  262. { Delphi distinguishes reDivByZero from reZeroDivide, but maps both to code 200. }
  263. (code: 208; cls: EZeroDivide; msg: @SZeroDivide),
  264. (code: 211; cls: EAbstractError; msg: @SAbstractError),
  265. (code: 212; cls: EExternalException; msg: @SExternalException),
  266. (code: 214; cls: EBusError; msg: @SBusError),
  267. (code: 215; cls: EIntOverflow; msg: @SIntOverflow),
  268. (code: 216; cls: EAccessViolation; msg: @SAccessViolation),
  269. (code: 217; cls: EControlC; msg: @SControlC),
  270. (code: 218; cls: EPrivilege; msg: @SPrivilege),
  271. (code: 219; cls: EInvalidCast; msg: @SInvalidCast),
  272. (code: 220; cls: EVariantError; msg: @SInvalidVarCast),
  273. (code: 221; cls: EVariantError; msg: @SInvalidVarOp),
  274. (code: 222; cls: EVariantError; msg: @SDispatchError),
  275. (code: 223; cls: EVariantError; msg: @SVarArrayCreate),
  276. (code: 224; cls: EVariantError; msg: @SVarNotArray),
  277. (code: 225; cls: EVariantError; msg: @SVarArrayBounds),
  278. (code: 227; cls: EAssertionFailed; msg: @SAssertionFailed),
  279. (code: 228; cls: EIntfCastError; msg: @SIntfCastError),
  280. (code: 229; cls: ESafecallException; msg: @SSafecallException),
  281. (code: 231; cls: EConvertError; msg: @SiconvError),
  282. (code: 232; cls: ENoThreadSupport; msg: @SNoThreadSupport),
  283. (code: 233; cls: ENoWideStringSupport; msg: @SSigQuit),
  284. (code: 234; cls: ENoWideStringSupport; msg: @SMissingWStringManager)
  285. );
  286. function FindExceptMapEntry(err: longint): PExceptMapEntry;
  287. var
  288. i: longint;
  289. begin
  290. for i:=low(exceptmap) to high(exceptmap) do
  291. if err=exceptmap[i].code then
  292. begin
  293. result:=@exceptmap[i];
  294. exit;
  295. end;
  296. result:=nil;
  297. end;
  298. Var OutOfMemory : EOutOfMemory;
  299. InValidPointer : EInvalidPointer;
  300. Procedure RunErrorToExcept (ErrNo : Longint; Address,Frame : Pointer);
  301. var
  302. E: Exception;
  303. HS: PString;
  304. Entry: PExceptMapEntry;
  305. begin
  306. Case Errno of
  307. 1,203 : E:=OutOfMemory;
  308. 204 : E:=InvalidPointer;
  309. else
  310. Entry:=FindExceptMapEntry(ErrNo);
  311. if Assigned(Entry) then
  312. E:=Entry^.cls.CreateRes(Entry^.msg)
  313. else
  314. begin
  315. HS:=nil;
  316. Case Errno of
  317. 2 : HS:=@SFileNotFound;
  318. 3 : HS:=@SInvalidFileName;
  319. 4 : HS:=@STooManyOpenFiles;
  320. 5 : HS:=@SAccessDenied;
  321. 6 : HS:=@SInvalidFileHandle;
  322. 15 : HS:=@SInvalidDrive;
  323. 100 : HS:=@SEndOfFile;
  324. 101 : HS:=@SDiskFull;
  325. 102 : HS:=@SFileNotAssigned;
  326. 103 : HS:=@SFileNotOpen;
  327. 104 : HS:=@SFileNotOpenForInput;
  328. 105 : HS:=@SFileNotOpenForOutput;
  329. 106 : HS:=@SInvalidInput;
  330. end;
  331. if Assigned(HS) then
  332. E:=EInOutError.CreateRes(HS)
  333. else
  334. E:=EInOutError.CreateResFmt(@SUnknownRunTimeError,[errno]);
  335. // this routine can be called from FPC_IOCHECK,
  336. // which clears inoutres and then passes its
  337. // original value to HandleErrorFrame() (which calls
  338. // us). So use errno rather than IOResult, and clear
  339. // InOutRes explicitly in case we can also be called
  340. // from a place that does not clear InOutRes explicitly
  341. EInoutError(E).ErrorCode:=errno;
  342. inoutres:=0;
  343. end;
  344. end;
  345. Raise E at Address,Frame;
  346. end;
  347. {$IFDEF HAS_OSERROR}
  348. Procedure RaiseLastOSError;
  349. var
  350. ECode: Cardinal;
  351. E : EOSError;
  352. begin
  353. ECode := GetLastOSError;
  354. If (ECode<>0) then
  355. E:=EOSError.CreateFmt(SOSError, [ECode, SysErrorMessage(ECode)])
  356. else
  357. E:=EOSError.Create(SUnkOSError);
  358. E.ErrorCode:=ECode;
  359. Raise E;
  360. end;
  361. {$else}
  362. Procedure RaiseLastOSError;
  363. begin
  364. Raise Exception.Create('RaiseLastOSError not implemented on this platform.');
  365. end;
  366. {$endif}
  367. Procedure AssertErrorHandler (Const Msg,FN : ShortString;LineNo:longint; TheAddr : pointer);
  368. Var
  369. S : String;
  370. begin
  371. If Msg='' then
  372. S:=SAssertionFailed
  373. else
  374. S:=Msg;
  375. Raise EAssertionFailed.Createfmt(SAssertError,[S,Fn,LineNo]) at get_caller_addr(theAddr), get_caller_frame(theAddr);
  376. end;
  377. {$pop} //{$S-} for Error handling functions
  378. Procedure InitExceptions;
  379. {
  380. Must install uncaught exception handler (ExceptProc)
  381. and install exceptions for system exceptions or signals.
  382. (e.g: SIGSEGV -> ESegFault or so.)
  383. }
  384. begin
  385. ExceptionClass := Exception;
  386. ExceptProc:=@CatchUnhandledException;
  387. // Create objects that may have problems when there is no memory.
  388. OutOfMemory:=EOutOfMemory.Create(SOutOfMemory);
  389. OutOfMemory.AllowFree:=false;
  390. InvalidPointer:=EInvalidPointer.Create(SInvalidPointer);
  391. InvalidPointer.AllowFree:=false;
  392. AssertErrorProc:=@AssertErrorHandler;
  393. ErrorProc:=@RunErrorToExcept;
  394. OnShowException:=Nil;
  395. end;
  396. Procedure DoneExceptions;
  397. begin
  398. OutOfMemory.AllowFree:=true;
  399. OutOfMemory.Free;
  400. InValidPointer.AllowFree:=true;
  401. InValidPointer.Free;
  402. end;
  403. { Exception handling routines }
  404. function ExceptObject: TObject;
  405. begin
  406. If RaiseList=Nil then
  407. Result:=Nil
  408. else
  409. Result:=RaiseList^.FObject;
  410. end;
  411. function ExceptAddr: Pointer;
  412. begin
  413. If RaiseList=Nil then
  414. Result:=Nil
  415. else
  416. Result:=RaiseList^.Addr;
  417. end;
  418. function ExceptFrameCount: Longint;
  419. begin
  420. If RaiseList=Nil then
  421. Result:=0
  422. else
  423. Result:=RaiseList^.Framecount;
  424. end;
  425. function ExceptFrames: PPointer;
  426. begin
  427. If RaiseList=Nil then
  428. Result:=Nil
  429. else
  430. Result:=RaiseList^.Frames;
  431. end;
  432. function ExceptionErrorMessage(ExceptObject: TObject; ExceptAddr: Pointer;
  433. Buffer: PChar; Size: Integer): Integer;
  434. Var
  435. S : AnsiString;
  436. Len : Integer;
  437. begin
  438. S:=Format(SExceptionErrorMessage,[ExceptAddr,ExceptObject.ClassName]);
  439. If ExceptObject is Exception then
  440. S:=Format('%s:'#10'%s',[S,Exception(ExceptObject).Message]);
  441. Len:=Length(S);
  442. If S[Len]<>'.' then
  443. begin
  444. S:=S+'.';
  445. Inc(len);
  446. end;
  447. If Len>Size then
  448. Len:=Size;
  449. if Len > 0 then
  450. Move(S[1],Buffer^,Len);
  451. Result:=Len;
  452. end;
  453. procedure ShowException(ExceptObject: TObject; ExceptAddr: Pointer);
  454. // use shortstring. On exception, the heap may be corrupt.
  455. Var
  456. Buf : ShortString;
  457. begin
  458. SetLength(Buf,ExceptionErrorMessage(ExceptObject,ExceptAddr,@Buf[1],255));
  459. If IsConsole Then
  460. writeln(Buf)
  461. else
  462. If Assigned(OnShowException) Then
  463. OnShowException (Buf);
  464. end;
  465. procedure Abort;
  466. begin
  467. Raise EAbort.Create(SAbortError) at Pointer(Get_Caller_addr(Get_Frame));
  468. end;
  469. procedure OutOfMemoryError;
  470. begin
  471. Raise OutOfMemory;
  472. end;
  473. { ---------------------------------------------------------------------
  474. Initialization/Finalization/exit code
  475. ---------------------------------------------------------------------}
  476. Type
  477. PPRecord = ^TPRecord;
  478. TPRecord = Record
  479. Func : TTerminateProc;
  480. NextFunc : PPRecord;
  481. end;
  482. Const
  483. TPList : PPRecord = Nil;
  484. procedure AddTerminateProc(TermProc: TTerminateProc);
  485. Var
  486. TPR : PPRecord;
  487. begin
  488. New(TPR);
  489. With TPR^ do
  490. begin
  491. NextFunc:=TPList;
  492. Func:=TermProc;
  493. end;
  494. TPList:=TPR;
  495. end;
  496. function CallTerminateProcs: Boolean;
  497. Var
  498. TPR : PPRecord;
  499. begin
  500. Result:=True;
  501. TPR:=TPList;
  502. While Result and (TPR<>Nil) do
  503. begin
  504. Result:=TPR^.Func();
  505. TPR:=TPR^.NextFunc;
  506. end;
  507. end;
  508. { ---------------------------------------------------------------------
  509. Diskh functions, OS independent.
  510. ---------------------------------------------------------------------}
  511. function ForceDirectories(Const Dir: string): Boolean;
  512. var
  513. E: EInOutError;
  514. ADrv : String;
  515. function DoForceDirectories(Const Dir: string): Boolean;
  516. var
  517. ADir : String;
  518. APath: String;
  519. begin
  520. Result:=True;
  521. ADir:=ExcludeTrailingPathDelimiter(Dir);
  522. if (ADir='') then Exit;
  523. if Not DirectoryExists(ADir) then
  524. begin
  525. APath := ExtractFilePath(ADir);
  526. //this can happen on Windows if user specifies Dir like \user\name/test/
  527. //and would, if not checked for, cause an infinite recusrsion and a stack overflow
  528. if (APath = ADir) then Result := False
  529. else Result:=DoForceDirectories(APath);
  530. If Result then
  531. Result := CreateDir(ADir);
  532. end;
  533. end;
  534. function IsUncDrive(const Drv: String): Boolean;
  535. begin
  536. Result := (Length(Drv) > 2) and (Drv[1] = PathDelim) and (Drv[2] = PathDelim);
  537. end;
  538. begin
  539. Result := False;
  540. ADrv := ExtractFileDrive(Dir);
  541. if (ADrv<>'') and (not DirectoryExists(ADrv))
  542. {$IFNDEF FORCEDIR_NO_UNC_SUPPORT} and (not IsUncDrive(ADrv)){$ENDIF} then Exit;
  543. if Dir='' then
  544. begin
  545. E:=EInOutError.Create(SCannotCreateEmptyDir);
  546. E.ErrorCode:=3;
  547. Raise E;
  548. end;
  549. Result := DoForceDirectories(SetDirSeparators(Dir));
  550. end;
  551. Var
  552. GUIDCalledRandomize : Boolean = False;
  553. Procedure GetRandomBytes(Var Buf; NBytes : Integer);
  554. Var
  555. I : Integer;
  556. P : PByte;
  557. begin
  558. P:=@Buf;
  559. If Not GUIDCalledRandomize then
  560. begin
  561. Randomize;
  562. GUIDCalledRandomize:=True;
  563. end;
  564. For I:=0 to NBytes-1 do
  565. P[i]:=Random(256);
  566. end;
  567. {$IFDEF HASCREATEGUID}
  568. Function SysCreateGUID(out GUID : TGUID) : Integer; forward;
  569. {$ENDIF}
  570. Function CreateGUID(out GUID : TGUID) : Integer;
  571. begin
  572. If Assigned(OnCreateGUID) then
  573. Result:=OnCreateGUID(GUID)
  574. else
  575. begin
  576. {$IFDEF HASCREATEGUID}
  577. Result:=SysCreateGUID(GUID);
  578. {$ELSE}
  579. GetRandomBytes(GUID,SizeOf(Guid));
  580. guid.clock_seq_hi_and_reserved:=(guid.clock_seq_hi_and_reserved and $3F) + 64;
  581. guid.time_hi_and_version :=(guid.time_hi_and_version and $0FFF)+ $4000;
  582. Result:=0;
  583. {$ENDIF}
  584. end;
  585. end;
  586. function SafeLoadLibrary(const FileName: AnsiString;
  587. ErrorMode: DWord = {$ifdef windows}SEM_NOOPENFILEERRORBOX{$else windows}0{$endif windows}): HMODULE;
  588. {$if defined(cpui386) or defined(cpux86_64)}
  589. var
  590. mode : DWord;
  591. fpucw : Word;
  592. ssecw : DWord;
  593. {$endif}
  594. begin
  595. {$if defined(win64) or defined(win32)}
  596. mode:=SetErrorMode(ErrorMode);
  597. {$endif}
  598. try
  599. {$if defined(cpui386) or defined(cpux86_64)}
  600. fpucw:=Get8087CW;
  601. {$ifdef cpui386}
  602. if has_sse_support then
  603. {$endif cpui386}
  604. ssecw:=GetSSECSR;
  605. {$endif}
  606. {$if defined(windows) or defined(win32)}
  607. Result:=LoadLibraryA(PChar(Filename));
  608. {$else}
  609. Result:=0;
  610. {$endif}
  611. finally
  612. {$if defined(cpui386) or defined(cpux86_64)}
  613. Set8087CW(fpucw);
  614. {$ifdef cpui386}
  615. if has_sse_support then
  616. {$endif cpui386}
  617. SetSSECSR(ssecw);
  618. {$endif}
  619. {$if defined(win64) or defined(win32)}
  620. SetErrorMode(mode);
  621. {$endif}
  622. end;
  623. end;
  624. function GetModuleName(Module: HMODULE): string;
  625. begin
  626. {$ifdef MSWINDOWS}
  627. SetLength(Result,MAX_PATH);
  628. SetLength(Result,GetModuleFileName(Module, Pchar(Result),Length(Result)));
  629. {$ELSE}
  630. Result:='';
  631. {$ENDIF}
  632. end;
  633. { Beep support }
  634. procedure Beep;
  635. begin
  636. If Assigned(OnBeep) then
  637. OnBeep;
  638. end;