mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-11-04 13:39:39 +01:00
493 lines
12 KiB
PHP
493 lines
12 KiB
PHP
{
|
|
$Id$
|
|
This file is part of the Free Pascal run time library.
|
|
Copyright (c) 1999-2000 by Florian Klaempfl
|
|
member of the Free Pascal development team
|
|
|
|
See the file COPYING.FPC, included in this distribution,
|
|
for details about the copyright.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
|
|
|
**********************************************************************}
|
|
|
|
{ Read filename handling functions implementation }
|
|
{$i fina.inc}
|
|
|
|
Function FileSearch (Const Name, DirList : String) : String;
|
|
Var
|
|
I : longint;
|
|
Temp : String;
|
|
|
|
begin
|
|
Result:='';
|
|
temp:=Dirlist;
|
|
repeat
|
|
While (Length(Temp)>0) and (Temp[1]=PathSeparator) do
|
|
Delete(Temp,1,1);
|
|
I:=pos(PathSep,Temp);
|
|
If I<>0 then
|
|
begin
|
|
Result:=Copy (Temp,1,i-1);
|
|
system.Delete(Temp,1,I);
|
|
end
|
|
else
|
|
begin
|
|
Result:=Temp;
|
|
Temp:='';
|
|
end;
|
|
If (Length(Result)>0) and (result[length(result)]<>DirectorySeparator) then
|
|
Result:=Result+DirectorySeparator;
|
|
Result:=Result+name;
|
|
If not FileExists(Result) Then
|
|
Result:='';
|
|
until (length(temp)=0) or (length(result)<>0);
|
|
end;
|
|
|
|
{$ifndef OS_FILEISREADONLY}
|
|
Function FileIsReadOnly(const FileName: String): Boolean;
|
|
|
|
begin
|
|
Result := (FileGetAttr(FileName) and faReadOnly) <> 0;
|
|
end;
|
|
{$endif OS_FILEISREADONLY}
|
|
|
|
|
|
{ Read String Handling functions implementation }
|
|
{$i sysstr.inc}
|
|
|
|
{ Read date & Time function implementations }
|
|
{$i dati.inc}
|
|
|
|
{ Read pchar handling functions implementation }
|
|
{$i syspch.inc}
|
|
|
|
{ MCBS functions }
|
|
{$i sysansi.inc}
|
|
|
|
{ CPU Specific code }
|
|
{$i sysutilp.inc}
|
|
|
|
procedure FreeAndNil(var obj);
|
|
var
|
|
temp: tobject;
|
|
begin
|
|
temp:=tobject(obj);
|
|
pointer(obj):=nil;
|
|
temp.free;
|
|
end;
|
|
|
|
{$ifdef HASINTF}
|
|
{ Interfaces support }
|
|
{$i sysuintf.inc}
|
|
{$endif HASINTF}
|
|
|
|
constructor Exception.Create(const msg : string);
|
|
|
|
begin
|
|
inherited create;
|
|
fmessage:=msg;
|
|
end;
|
|
|
|
|
|
constructor Exception.CreateFmt(const msg : string; const args : array of const);
|
|
|
|
begin
|
|
inherited create;
|
|
fmessage:=Format(msg,args);
|
|
end;
|
|
|
|
|
|
constructor Exception.CreateRes(ResString: PString);
|
|
|
|
begin
|
|
inherited create;
|
|
fmessage:=ResString^;
|
|
end;
|
|
|
|
|
|
constructor Exception.CreateResFmt(ResString: PString; const Args: array of const);
|
|
|
|
begin
|
|
inherited create;
|
|
fmessage:=Format(ResString^,args);
|
|
end;
|
|
|
|
|
|
constructor Exception.CreateHelp(const Msg: string; AHelpContext: Integer);
|
|
|
|
begin
|
|
inherited create;
|
|
fmessage:=Msg;
|
|
fhelpcontext:=AHelpContext;
|
|
end;
|
|
|
|
|
|
constructor Exception.CreateFmtHelp(const Msg: string; const Args: array of const;
|
|
AHelpContext: Integer);
|
|
|
|
begin
|
|
inherited create;
|
|
fmessage:=Format(Msg,args);
|
|
fhelpcontext:=AHelpContext;
|
|
end;
|
|
|
|
|
|
constructor Exception.CreateResHelp(ResString: PString; AHelpContext: Integer);
|
|
|
|
begin
|
|
inherited create;
|
|
fmessage:=ResString^;
|
|
fhelpcontext:=AHelpContext;
|
|
end;
|
|
|
|
|
|
constructor Exception.CreateResFmtHelp(ResString: PString; const Args: array of const;
|
|
AHelpContext: Integer);
|
|
|
|
begin
|
|
inherited create;
|
|
fmessage:=Format(ResString^,args);
|
|
fhelpcontext:=AHelpContext;
|
|
end;
|
|
|
|
|
|
procedure EHeapMemoryError.FreeInstance;
|
|
begin
|
|
if AllowFree then
|
|
inherited FreeInstance;
|
|
end;
|
|
|
|
|
|
{$ifopt S+}
|
|
{$define STACKCHECK_WAS_ON}
|
|
{$S-}
|
|
{$endif OPT S }
|
|
Procedure CatchUnhandledException (Obj : TObject; Addr,Frame: Pointer);
|
|
Var
|
|
Message : String;
|
|
{$IFDEF VIRTUALPASCAL}
|
|
stdout:text absolute output;
|
|
{$ENDIF}
|
|
begin
|
|
Writeln(stdout,'An unhandled exception occurred at 0x',HexStr(Longint(Addr),8),' :');
|
|
if Obj is exception then
|
|
begin
|
|
Message:=Exception(Obj).ClassName+' : '+Exception(Obj).Message;
|
|
Writeln(stdout,Message);
|
|
end
|
|
else
|
|
Writeln(stdout,'Exception object ',Obj.ClassName,' is not of class Exception.');
|
|
{ to get a nice symify }
|
|
{$IFNDEF VIRTUALPASCAL}
|
|
Writeln(stdout,BackTraceStrFunc(Addr));
|
|
Dump_Stack(stdout,frame);
|
|
{$ENDIF}
|
|
Writeln(stdout,'');
|
|
Halt(217);
|
|
end;
|
|
|
|
|
|
Var OutOfMemory : EOutOfMemory;
|
|
InValidPointer : EInvalidPointer;
|
|
|
|
|
|
Procedure RunErrorToExcept (ErrNo : Longint; Address,Frame : Pointer);
|
|
|
|
Var E : Exception;
|
|
S : String;
|
|
|
|
begin
|
|
Case Errno of
|
|
1,203 : E:=OutOfMemory;
|
|
204 : E:=InvalidPointer;
|
|
2,3,4,5,6,100,101,102,103,105,106 : { I/O errors }
|
|
begin
|
|
Case Errno of
|
|
2 : S:=SFileNotFound;
|
|
3 : S:=SInvalidFileName;
|
|
4 : S:=STooManyOpenFiles;
|
|
5 : S:=SAccessDenied;
|
|
6 : S:=SInvalidFileHandle;
|
|
15 : S:=SInvalidDrive;
|
|
100 : S:=SEndOfFile;
|
|
101 : S:=SDiskFull;
|
|
102 : S:=SFileNotAssigned;
|
|
103 : S:=SFileNotOpen;
|
|
104 : S:=SFileNotOpenForInput;
|
|
105 : S:=SFileNotOpenForOutput;
|
|
106 : S:=SInvalidInput;
|
|
end;
|
|
E:=EinOutError.Create (S);
|
|
EInoutError(E).ErrorCode:=IOresult; // Clears InOutRes !!
|
|
end;
|
|
// We don't set abstracterrorhandler, but we do it here.
|
|
// Unless the use sets another handler we'll get here anyway...
|
|
200 : E:=EDivByZero.Create(SDivByZero);
|
|
201 : E:=ERangeError.Create(SRangeError);
|
|
205 : E:=EOverflow.Create(SOverflow);
|
|
206 : E:=EOverflow.Create(SUnderflow);
|
|
207 : E:=EInvalidOp.Create(SInvalidOp);
|
|
211 : E:=EAbstractError.Create(SAbstractError);
|
|
215 : E:=EIntOverflow.Create(SIntOverflow);
|
|
216 : E:=EAccessViolation.Create(SAccessViolation);
|
|
217 : E:=EPrivilege.Create(SPrivilege);
|
|
218 : E:=EControlC.Create(SControlC);
|
|
219 : E:=EInvalidCast.Create(SInvalidCast);
|
|
220 : E:=EVariantError.Create(SInvalidVarCast);
|
|
221 : E:=EVariantError.Create(SInvalidVarOp);
|
|
222 : E:=EVariantError.Create(SDispatchError);
|
|
223 : E:=EVariantError.Create(SVarArrayCreate);
|
|
224 : E:=EVariantError.Create(SVarNotArray);
|
|
225 : E:=EVariantError.Create(SVarArrayBounds);
|
|
227 : E:=EAssertionFailed.Create(SAssertionFailed);
|
|
228 : E:=EExternalException.Create(SExternalException);
|
|
229 : E:=EIntfCastError.Create(SIntfCastError);
|
|
230 : E:=ESafecallException.Create(SSafecallException);
|
|
232 : E:=ENoThreadSupport.Create(SNoThreadSupport);
|
|
else
|
|
E:=Exception.CreateFmt (SUnKnownRunTimeError,[Errno]);
|
|
end;
|
|
{$ifdef VER1_0}
|
|
Raise E at longint(Address){$ifdef ENHANCEDRAISE},longint(Frame){$endif};
|
|
{$else VER1_0}
|
|
Raise E at Address,Frame;
|
|
{$endif VER1_0}
|
|
end;
|
|
|
|
{$IFDEF HAS_OSERROR}
|
|
Procedure RaiseLastOSError;
|
|
|
|
var
|
|
ECode: Cardinal;
|
|
E : EOSError;
|
|
|
|
begin
|
|
ECode := GetLastOSError;
|
|
If (ECode<>0) then
|
|
E:=EOSError.CreateFmt(SOSError, [ECode, SysErrorMessage(ECode)])
|
|
else
|
|
E:=EOSError.Create(SUnkOSError);
|
|
E.ErrorCode:=ECode;
|
|
Raise E;
|
|
end;
|
|
{$else}
|
|
Procedure RaiseLastOSError;
|
|
|
|
begin
|
|
Raise Exception.Create('RaiseLastOSError not implemented on this platform.');
|
|
end;
|
|
{$endif}
|
|
Procedure AssertErrorHandler (Const Msg,FN : ShortString;LineNo:longint; TheAddr : pointer);
|
|
Var
|
|
S : String;
|
|
begin
|
|
If Msg='' then
|
|
S:=SAssertionFailed
|
|
else
|
|
S:=Msg;
|
|
Raise EAssertionFailed.Createfmt(SAssertError,[S,Fn,LineNo]); // at Pointer(theAddr);
|
|
end;
|
|
|
|
{$ifdef STACKCHECK_WAS_ON}
|
|
{$S+}
|
|
{$endif}
|
|
|
|
Procedure InitExceptions;
|
|
{
|
|
Must install uncaught exception handler (ExceptProc)
|
|
and install exceptions for system exceptions or signals.
|
|
(e.g: SIGSEGV -> ESegFault or so.)
|
|
}
|
|
begin
|
|
ExceptProc:=@CatchUnhandledException;
|
|
// Create objects that may have problems when there is no memory.
|
|
OutOfMemory:=EOutOfMemory.Create(SOutOfMemory);
|
|
OutOfMemory.AllowFree:=false;
|
|
InvalidPointer:=EInvalidPointer.Create(SInvalidPointer);
|
|
InvalidPointer.AllowFree:=false;
|
|
AssertErrorProc:=@AssertErrorHandler;
|
|
ErrorProc:=@RunErrorToExcept;
|
|
OnShowException:=Nil;
|
|
end;
|
|
|
|
|
|
Procedure DoneExceptions;
|
|
begin
|
|
OutOfMemory.AllowFree:=true;
|
|
OutOfMemory.Free;
|
|
InValidPointer.AllowFree:=true;
|
|
InValidPointer.Free;
|
|
end;
|
|
|
|
|
|
{ Exception handling routines }
|
|
|
|
function ExceptObject: TObject;
|
|
|
|
begin
|
|
{$IFDEF VIRTUALPASCAL}
|
|
// vpascal does exceptions more the delphi way...
|
|
// this needs to be written from scratch.
|
|
{$ELSE}
|
|
If RaiseList=Nil then
|
|
Result:=Nil
|
|
else
|
|
Result:=RaiseList^.FObject;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function ExceptAddr: Pointer;
|
|
|
|
begin
|
|
{$IFDEF VIRTUALPASCAL}
|
|
// vpascal does exceptions more the delphi way...
|
|
// this needs to be written from scratch.
|
|
{$ELSE}
|
|
If RaiseList=Nil then
|
|
Result:=Nil
|
|
else
|
|
Result:=RaiseList^.Addr;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function ExceptionErrorMessage(ExceptObject: TObject; ExceptAddr: Pointer;
|
|
Buffer: PChar; Size: Integer): Integer;
|
|
|
|
Var
|
|
S : AnsiString;
|
|
Len : Integer;
|
|
|
|
begin
|
|
S:=Format(SExceptionErrorMessage,[ExceptObject.ClassName,ExceptAddr]);
|
|
If ExceptObject is Exception then
|
|
S:=Format('%s:'#10'%s',[S,Exception(ExceptObject).Message]);
|
|
Len:=Length(S);
|
|
If S[Len]<>'.' then
|
|
begin
|
|
S:=S+'.';
|
|
Inc(len);
|
|
end;
|
|
If Len>Size then
|
|
Len:=Size;
|
|
if Len > 0 then
|
|
Move(S[1],Buffer^,Len);
|
|
Result:=Len;
|
|
end;
|
|
|
|
procedure ShowException(ExceptObject: TObject; ExceptAddr: Pointer);
|
|
|
|
// use shortstring. On exception, the heap may be corrupt.
|
|
|
|
Var
|
|
Buf : ShortString;
|
|
|
|
begin
|
|
SetLength(Buf,ExceptionErrorMessage(ExceptObject,ExceptAddr,@Buf[1],255));
|
|
If IsConsole Then
|
|
writeln(Buf)
|
|
else
|
|
If Assigned(OnShowException) Then
|
|
OnShowException (Buf);
|
|
end;
|
|
|
|
procedure Abort;
|
|
|
|
begin
|
|
{$ifdef VER1_0}
|
|
Raise EAbort.Create(SAbortError) at Longint(Get_Caller_addr(Get_Frame));
|
|
{$else VER1_0}
|
|
Raise EAbort.Create(SAbortError)
|
|
{$IFNDEF VIRTUALPASCAL}
|
|
at Pointer(Get_Caller_addr(Get_Frame));
|
|
{$ENDIF}
|
|
{$endif VER1_0}
|
|
end;
|
|
|
|
procedure OutOfMemoryError;
|
|
|
|
begin
|
|
Raise OutOfMemory;
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------
|
|
Initialization/Finalization/exit code
|
|
---------------------------------------------------------------------}
|
|
|
|
Type
|
|
PPRecord = ^TPRecord;
|
|
TPRecord = Record
|
|
Func : TTerminateProc;
|
|
NextFunc : PPRecord;
|
|
end;
|
|
|
|
Const
|
|
TPList : PPRecord = Nil;
|
|
|
|
procedure AddTerminateProc(TermProc: TTerminateProc);
|
|
|
|
Var
|
|
TPR : PPRecord;
|
|
|
|
begin
|
|
New(TPR);
|
|
With TPR^ do
|
|
begin
|
|
NextFunc:=TPList;
|
|
Func:=TermProc;
|
|
end;
|
|
TPList:=TPR;
|
|
end;
|
|
|
|
function CallTerminateProcs: Boolean;
|
|
|
|
Var
|
|
TPR : PPRecord;
|
|
|
|
begin
|
|
Result:=True;
|
|
TPR:=TPList;
|
|
While Result and (TPR<>Nil) do
|
|
begin
|
|
Result:=TPR^.Func();
|
|
TPR:=TPR^.NextFunc;
|
|
end;
|
|
end;
|
|
|
|
{
|
|
Revision 1.1 2003/10/06 21:01:06 peter
|
|
* moved classes unit to rtl
|
|
|
|
Revision 1.17 2003/09/06 20:46:07 marco
|
|
* 3 small VP fixes from Noah Silva. One (OutOfMemory error) failed.
|
|
|
|
Revision 1.16 2003/04/06 11:06:39 michael
|
|
+ Added exception classname to output of unhandled exception for better identification
|
|
|
|
Revision 1.15 2003/03/18 08:28:23 michael
|
|
Patch from peter for Abort routine
|
|
|
|
Revision 1.14 2003/03/17 15:11:51 armin
|
|
+ someone AssertErrorHandler, BackTraceFunc and Dump_Stack so that pointer instead of longint is needed
|
|
|
|
Revision 1.13 2003/01/01 20:58:07 florian
|
|
+ added invalid instruction exception
|
|
|
|
Revision 1.12 2002/10/07 19:43:24 florian
|
|
+ empty prototypes for the AnsiStr* multi byte functions added
|
|
|
|
Revision 1.11 2002/09/07 16:01:22 peter
|
|
* old logs removed and tabs fixed
|
|
|
|
Revision 1.10 2002/07/16 13:57:39 florian
|
|
* raise takes now a void pointer as at and frame address
|
|
instead of a longint, fixed
|
|
|
|
Revision 1.9 2002/01/25 17:42:03 peter
|
|
* interface helpers
|
|
|
|
Revision 1.8 2002/01/25 16:23:03 peter
|
|
* merged filesearch() fix
|
|
} |