sysutils.inc 12 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525
  1. {
  2. $Id$
  3. This file is part of the Free Pascal run time library.
  4. Copyright (c) 1999-2000 by Florian Klaempfl
  5. member of the Free Pascal development team
  6. See the file COPYING.FPC, included in this distribution,
  7. for details about the copyright.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  11. **********************************************************************}
  12. { Read filename handling functions implementation }
  13. {$i fina.inc}
  14. Function FileSearch (Const Name, DirList : String) : String;
  15. Var
  16. I : longint;
  17. Temp : String;
  18. begin
  19. Result:='';
  20. temp:=Dirlist;
  21. repeat
  22. While (Length(Temp)>0) and (Temp[1]=PathSeparator) do
  23. Delete(Temp,1,1);
  24. I:=pos(PathSep,Temp);
  25. If I<>0 then
  26. begin
  27. Result:=Copy (Temp,1,i-1);
  28. system.Delete(Temp,1,I);
  29. end
  30. else
  31. begin
  32. Result:=Temp;
  33. Temp:='';
  34. end;
  35. If (Length(Result)>0) and (result[length(result)]<>DirectorySeparator) then
  36. Result:=Result+DirectorySeparator;
  37. Result:=Result+name;
  38. If not FileExists(Result) Then
  39. Result:='';
  40. until (length(temp)=0) or (length(result)<>0);
  41. end;
  42. {$ifndef OS_FILEISREADONLY}
  43. Function FileIsReadOnly(const FileName: String): Boolean;
  44. begin
  45. Result := (FileGetAttr(FileName) and faReadOnly) <> 0;
  46. end;
  47. {$endif OS_FILEISREADONLY}
  48. { Read String Handling functions implementation }
  49. {$i sysstr.inc}
  50. { Read date & Time function implementations }
  51. {$i dati.inc}
  52. { Read pchar handling functions implementation }
  53. {$i syspch.inc}
  54. { MCBS functions }
  55. {$i sysansi.inc}
  56. { CPU Specific code }
  57. {$i sysutilp.inc}
  58. { OS utility code }
  59. {$i osutil.inc}
  60. procedure FreeAndNil(var obj);
  61. var
  62. temp: tobject;
  63. begin
  64. temp:=tobject(obj);
  65. pointer(obj):=nil;
  66. temp.free;
  67. end;
  68. {$ifdef HASINTF}
  69. { Interfaces support }
  70. {$i sysuintf.inc}
  71. {$endif HASINTF}
  72. constructor Exception.Create(const msg : string);
  73. begin
  74. inherited create;
  75. fmessage:=msg;
  76. end;
  77. constructor Exception.CreateFmt(const msg : string; const args : array of const);
  78. begin
  79. inherited create;
  80. fmessage:=Format(msg,args);
  81. end;
  82. constructor Exception.CreateRes(ResString: PString);
  83. begin
  84. inherited create;
  85. fmessage:=ResString^;
  86. end;
  87. constructor Exception.CreateResFmt(ResString: PString; const Args: array of const);
  88. begin
  89. inherited create;
  90. fmessage:=Format(ResString^,args);
  91. end;
  92. constructor Exception.CreateHelp(const Msg: string; AHelpContext: Integer);
  93. begin
  94. inherited create;
  95. fmessage:=Msg;
  96. fhelpcontext:=AHelpContext;
  97. end;
  98. constructor Exception.CreateFmtHelp(const Msg: string; const Args: array of const;
  99. AHelpContext: Integer);
  100. begin
  101. inherited create;
  102. fmessage:=Format(Msg,args);
  103. fhelpcontext:=AHelpContext;
  104. end;
  105. constructor Exception.CreateResHelp(ResString: PString; AHelpContext: Integer);
  106. begin
  107. inherited create;
  108. fmessage:=ResString^;
  109. fhelpcontext:=AHelpContext;
  110. end;
  111. constructor Exception.CreateResFmtHelp(ResString: PString; const Args: array of const;
  112. AHelpContext: Integer);
  113. begin
  114. inherited create;
  115. fmessage:=Format(ResString^,args);
  116. fhelpcontext:=AHelpContext;
  117. end;
  118. procedure EHeapMemoryError.FreeInstance;
  119. begin
  120. if AllowFree then
  121. inherited FreeInstance;
  122. end;
  123. {$ifopt S+}
  124. {$define STACKCHECK_WAS_ON}
  125. {$S-}
  126. {$endif OPT S }
  127. Procedure CatchUnhandledException (Obj : TObject; Addr,Frame: Pointer);[public,alias:'FPC_BREAK_UNHANDLED_EXCEPTION'];
  128. Var
  129. Message : String;
  130. {$IFDEF VIRTUALPASCAL}
  131. stdout:text absolute output;
  132. {$ENDIF}
  133. begin
  134. Writeln(stdout,'An unhandled exception occurred at 0x',HexStr(Ptrint(Addr),sizeof(PtrInt)*2),' :');
  135. if Obj is exception then
  136. begin
  137. Message:=Exception(Obj).ClassName+' : '+Exception(Obj).Message;
  138. Writeln(stdout,Message);
  139. end
  140. else
  141. Writeln(stdout,'Exception object ',Obj.ClassName,' is not of class Exception.');
  142. { to get a nice symify }
  143. {$IFNDEF VIRTUALPASCAL}
  144. Writeln(stdout,BackTraceStrFunc(Addr));
  145. Dump_Stack(stdout,frame);
  146. {$ENDIF}
  147. Writeln(stdout,'');
  148. Halt(217);
  149. end;
  150. Var OutOfMemory : EOutOfMemory;
  151. InValidPointer : EInvalidPointer;
  152. Procedure RunErrorToExcept (ErrNo : Longint; Address,Frame : Pointer);
  153. Var E : Exception;
  154. S : String;
  155. begin
  156. Case Errno of
  157. 1,203 : E:=OutOfMemory;
  158. 204 : E:=InvalidPointer;
  159. 2,3,4,5,6,100,101,102,103,105,106 : { I/O errors }
  160. begin
  161. Case Errno of
  162. 2 : S:=SFileNotFound;
  163. 3 : S:=SInvalidFileName;
  164. 4 : S:=STooManyOpenFiles;
  165. 5 : S:=SAccessDenied;
  166. 6 : S:=SInvalidFileHandle;
  167. 15 : S:=SInvalidDrive;
  168. 100 : S:=SEndOfFile;
  169. 101 : S:=SDiskFull;
  170. 102 : S:=SFileNotAssigned;
  171. 103 : S:=SFileNotOpen;
  172. 104 : S:=SFileNotOpenForInput;
  173. 105 : S:=SFileNotOpenForOutput;
  174. 106 : S:=SInvalidInput;
  175. end;
  176. E:=EinOutError.Create (S);
  177. EInoutError(E).ErrorCode:=IOresult; // Clears InOutRes !!
  178. end;
  179. // We don't set abstracterrorhandler, but we do it here.
  180. // Unless the use sets another handler we'll get here anyway...
  181. 200 : E:=EDivByZero.Create(SDivByZero);
  182. 201 : E:=ERangeError.Create(SRangeError);
  183. 205 : E:=EOverflow.Create(SOverflow);
  184. 206 : E:=EOverflow.Create(SUnderflow);
  185. 207 : E:=EInvalidOp.Create(SInvalidOp);
  186. 211 : E:=EAbstractError.Create(SAbstractError);
  187. 215 : E:=EIntOverflow.Create(SIntOverflow);
  188. 216 : E:=EAccessViolation.Create(SAccessViolation);
  189. 217 : E:=EPrivilege.Create(SPrivilege);
  190. 218 : E:=EControlC.Create(SControlC);
  191. 219 : E:=EInvalidCast.Create(SInvalidCast);
  192. 220 : E:=EVariantError.Create(SInvalidVarCast);
  193. 221 : E:=EVariantError.Create(SInvalidVarOp);
  194. 222 : E:=EVariantError.Create(SDispatchError);
  195. 223 : E:=EVariantError.Create(SVarArrayCreate);
  196. 224 : E:=EVariantError.Create(SVarNotArray);
  197. 225 : E:=EVariantError.Create(SVarArrayBounds);
  198. 227 : E:=EAssertionFailed.Create(SAssertionFailed);
  199. 228 : E:=EExternalException.Create(SExternalException);
  200. 229 : E:=EIntfCastError.Create(SIntfCastError);
  201. 230 : E:=ESafecallException.Create(SSafecallException);
  202. 232 : E:=ENoThreadSupport.Create(SNoThreadSupport);
  203. else
  204. E:=Exception.CreateFmt (SUnKnownRunTimeError,[Errno]);
  205. end;
  206. {$ifdef VER1_0}
  207. Raise E at longint(Address){$ifdef ENHANCEDRAISE},longint(Frame){$endif};
  208. {$else VER1_0}
  209. Raise E at Address,Frame;
  210. {$endif VER1_0}
  211. end;
  212. {$IFDEF HAS_OSERROR}
  213. Procedure RaiseLastOSError;
  214. var
  215. ECode: Cardinal;
  216. E : EOSError;
  217. begin
  218. ECode := GetLastOSError;
  219. If (ECode<>0) then
  220. E:=EOSError.CreateFmt(SOSError, [ECode, SysErrorMessage(ECode)])
  221. else
  222. E:=EOSError.Create(SUnkOSError);
  223. E.ErrorCode:=ECode;
  224. Raise E;
  225. end;
  226. {$else}
  227. Procedure RaiseLastOSError;
  228. begin
  229. Raise Exception.Create('RaiseLastOSError not implemented on this platform.');
  230. end;
  231. {$endif}
  232. Procedure AssertErrorHandler (Const Msg,FN : ShortString;LineNo:longint; TheAddr : pointer);
  233. Var
  234. S : String;
  235. begin
  236. If Msg='' then
  237. S:=SAssertionFailed
  238. else
  239. S:=Msg;
  240. Raise EAssertionFailed.Createfmt(SAssertError,[S,Fn,LineNo]); // at Pointer(theAddr);
  241. end;
  242. {$ifdef STACKCHECK_WAS_ON}
  243. {$S+}
  244. {$endif}
  245. Procedure InitExceptions;
  246. {
  247. Must install uncaught exception handler (ExceptProc)
  248. and install exceptions for system exceptions or signals.
  249. (e.g: SIGSEGV -> ESegFault or so.)
  250. }
  251. begin
  252. ExceptProc:=@CatchUnhandledException;
  253. // Create objects that may have problems when there is no memory.
  254. OutOfMemory:=EOutOfMemory.Create(SOutOfMemory);
  255. OutOfMemory.AllowFree:=false;
  256. InvalidPointer:=EInvalidPointer.Create(SInvalidPointer);
  257. InvalidPointer.AllowFree:=false;
  258. AssertErrorProc:=@AssertErrorHandler;
  259. ErrorProc:=@RunErrorToExcept;
  260. OnShowException:=Nil;
  261. end;
  262. Procedure DoneExceptions;
  263. begin
  264. OutOfMemory.AllowFree:=true;
  265. OutOfMemory.Free;
  266. InValidPointer.AllowFree:=true;
  267. InValidPointer.Free;
  268. end;
  269. { Exception handling routines }
  270. function ExceptObject: TObject;
  271. begin
  272. {$IFDEF VIRTUALPASCAL}
  273. // vpascal does exceptions more the delphi way...
  274. // this needs to be written from scratch.
  275. {$ELSE}
  276. If RaiseList=Nil then
  277. Result:=Nil
  278. else
  279. Result:=RaiseList^.FObject;
  280. {$ENDIF}
  281. end;
  282. function ExceptAddr: Pointer;
  283. begin
  284. {$IFDEF VIRTUALPASCAL}
  285. // vpascal does exceptions more the delphi way...
  286. // this needs to be written from scratch.
  287. {$ELSE}
  288. If RaiseList=Nil then
  289. Result:=Nil
  290. else
  291. Result:=RaiseList^.Addr;
  292. {$ENDIF}
  293. end;
  294. function ExceptionErrorMessage(ExceptObject: TObject; ExceptAddr: Pointer;
  295. Buffer: PChar; Size: Integer): Integer;
  296. Var
  297. S : AnsiString;
  298. Len : Integer;
  299. begin
  300. S:=Format(SExceptionErrorMessage,[ExceptAddr,ExceptObject.ClassName]);
  301. If ExceptObject is Exception then
  302. S:=Format('%s:'#10'%s',[S,Exception(ExceptObject).Message]);
  303. Len:=Length(S);
  304. If S[Len]<>'.' then
  305. begin
  306. S:=S+'.';
  307. Inc(len);
  308. end;
  309. If Len>Size then
  310. Len:=Size;
  311. if Len > 0 then
  312. Move(S[1],Buffer^,Len);
  313. Result:=Len;
  314. end;
  315. procedure ShowException(ExceptObject: TObject; ExceptAddr: Pointer);
  316. // use shortstring. On exception, the heap may be corrupt.
  317. Var
  318. Buf : ShortString;
  319. begin
  320. SetLength(Buf,ExceptionErrorMessage(ExceptObject,ExceptAddr,@Buf[1],255));
  321. If IsConsole Then
  322. writeln(Buf)
  323. else
  324. If Assigned(OnShowException) Then
  325. OnShowException (Buf);
  326. end;
  327. procedure Abort;
  328. begin
  329. {$ifdef VER1_0}
  330. Raise EAbort.Create(SAbortError) at Longint(Get_Caller_addr(Get_Frame));
  331. {$else VER1_0}
  332. Raise EAbort.Create(SAbortError)
  333. {$IFNDEF VIRTUALPASCAL}
  334. at Pointer(Get_Caller_addr(Get_Frame));
  335. {$ENDIF}
  336. {$endif VER1_0}
  337. end;
  338. procedure OutOfMemoryError;
  339. begin
  340. Raise OutOfMemory;
  341. end;
  342. { ---------------------------------------------------------------------
  343. Initialization/Finalization/exit code
  344. ---------------------------------------------------------------------}
  345. Type
  346. PPRecord = ^TPRecord;
  347. TPRecord = Record
  348. Func : TTerminateProc;
  349. NextFunc : PPRecord;
  350. end;
  351. Const
  352. TPList : PPRecord = Nil;
  353. procedure AddTerminateProc(TermProc: TTerminateProc);
  354. Var
  355. TPR : PPRecord;
  356. begin
  357. New(TPR);
  358. With TPR^ do
  359. begin
  360. NextFunc:=TPList;
  361. Func:=TermProc;
  362. end;
  363. TPList:=TPR;
  364. end;
  365. function CallTerminateProcs: Boolean;
  366. Var
  367. TPR : PPRecord;
  368. begin
  369. Result:=True;
  370. TPR:=TPList;
  371. While Result and (TPR<>Nil) do
  372. begin
  373. Result:=TPR^.Func();
  374. TPR:=TPR^.NextFunc;
  375. end;
  376. end;
  377. { ---------------------------------------------------------------------
  378. Diskh functions, OS independent.
  379. ---------------------------------------------------------------------}
  380. function ForceDirectories(Const Dir: string): Boolean;
  381. var
  382. E: EInOutError;
  383. ADir : String;
  384. begin
  385. Result:=True;
  386. ADir:=ExcludeTrailingPathDelimiter(Dir);
  387. if (ADir='') then
  388. begin
  389. E:=EInOutError.Create(SCannotCreateEmptyDir);
  390. E.ErrorCode:=3;
  391. Raise E;
  392. end;
  393. if Not DirectoryExists(ADir) then
  394. begin
  395. Result:=ForceDirectories(ExtractFilePath(ADir));
  396. If Result then
  397. CreateDir(ADir);
  398. end;
  399. end;
  400. {
  401. Revision 1.1 2003/10/06 21:01:06 peter
  402. * moved classes unit to rtl
  403. Revision 1.17 2003/09/06 20:46:07 marco
  404. * 3 small VP fixes from Noah Silva. One (OutOfMemory error) failed.
  405. Revision 1.16 2003/04/06 11:06:39 michael
  406. + Added exception classname to output of unhandled exception for better identification
  407. Revision 1.15 2003/03/18 08:28:23 michael
  408. Patch from peter for Abort routine
  409. Revision 1.14 2003/03/17 15:11:51 armin
  410. + someone AssertErrorHandler, BackTraceFunc and Dump_Stack so that pointer instead of longint is needed
  411. Revision 1.13 2003/01/01 20:58:07 florian
  412. + added invalid instruction exception
  413. Revision 1.12 2002/10/07 19:43:24 florian
  414. + empty prototypes for the AnsiStr* multi byte functions added
  415. Revision 1.11 2002/09/07 16:01:22 peter
  416. * old logs removed and tabs fixed
  417. Revision 1.10 2002/07/16 13:57:39 florian
  418. * raise takes now a void pointer as at and frame address
  419. instead of a longint, fixed
  420. Revision 1.9 2002/01/25 17:42:03 peter
  421. * interface helpers
  422. Revision 1.8 2002/01/25 16:23:03 peter
  423. * merged filesearch() fix
  424. }