diff options
Diffstat (limited to 'plugins/Libs/err.pas')
| -rw-r--r-- | plugins/Libs/err.pas | 1199 |
1 files changed, 1199 insertions, 0 deletions
diff --git a/plugins/Libs/err.pas b/plugins/Libs/err.pas new file mode 100644 index 0000000000..ce21564e2d --- /dev/null +++ b/plugins/Libs/err.pas @@ -0,0 +1,1199 @@ +//{$DEFINE ASM_VERSION}
+//{$DEFINE VARIANT_USED}
+
+{$IFDEF ASM_VERSION}
+ {$IFDEF PAS_VERSION}
+ {$UNDEF ASM_VERSION}
+ {$ENDIF}
+{$ENDIF}
+
+{=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
+
+ KKKKK KKKKK OOOOOOOOO LLLLL
+ KKKKK KKKKK OOOOOOOOOOOOO LLLLL
+ KKKKK KKKKK OOOOO OOOOO LLLLL
+ KKKKK KKKKK OOOOO OOOOO LLLLL
+ KKKKKKKKKK OOOOO OOOOO LLLLL
+ KKKKK KKKKK OOOOO OOOOO LLLLL
+ KKKKK KKKKK OOOOO OOOOO LLLLL
+ KKKKK KKKKK OOOOOOOOOOOOO LLLLLLLLLLLLL
+ KKKKK KKKKK OOOOOOOOO LLLLLLLLLLLLL
+
+ Key Objects Library (C) 2000 by Kladov Vladimir.
+
+ mailto: bonanzas@xcl.cjb.net
+ Home: http://kol.nm.ru
+ http://xcl.cjb.net
+ http://xcl.nm.ru
+
+ =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-}
+{
+ This code is grabbed mainly from standard SysUtils.pas unit,
+ provided by Borland Delphi. This unit is for handling exceptions,
+ and to use it just place a reference to exceptions unit in
+ uses clause of any of your unit or dpr-file.
+}
+
+{ Copyright (C) 1995,99 Inprise Corporation }
+{ Copyright (C) 2001, Kladov Vladimir }
+
+unit err;
+{* Unit to provide error handling for KOL programs using efficient
+ exceptions mechanism. To use it, just place a reference to it into
+ uses clause of any unit of the project (or dpr-file).
+ |<br><br>
+ It is possible to use standard SysUtils instead, but it increases
+ size of executable at least by 10K. Using this unit to handle exceptions
+ increases executable only by 6,5K.
+}
+
+interface
+
+uses Windows, KOL;
+
+{$I KOLDEF.INC}
+{$IFDEF _D6orHigher}
+ {$WARN SYMBOL_DEPRECATED OFF}
+{$ENDIF}
+{$IFDEF _D7orHigher}
+ {$WARN UNSAFE_TYPE OFF}
+ {$WARN UNSAFE_CODE OFF}
+{$ENDIF}
+
+{+} // These resource strings are grabbed from SysConst and changed a bit to make it smaller.
+
+//{$DEFINE USE_RESOURCESTRING}
+{$IFDEF _D2orD3}
+ {$IFDEF USE_RESOURCESTRING}
+ {$UNDEF USE_RESOURCESTRING}
+ {$ENDIF}
+{$ENDIF}
+
+{$IFDEF _D2orD3}
+type
+ LongWord = DWORD;
+{$ENDIF}
+{$IFNDEF USE_RESOURCESTRING}
+const
+{$ELSE}
+resourcestring
+{$ENDIF}
+ SUnknown = '<unknown>';
+ //SInvalidInteger = '''%s'' is not a valid integer value';
+ //SInvalidFloat = '''%s'' is not a valid floating point value';
+ //SInvalidDate = '''%s'' is not a valid date';
+ //SInvalidTime = '''%s'' is not a valid time';
+ //SInvalidDateTime = '''%s'' is not a valid date and time';
+ //STimeEncodeError = 'Invalid argument to time encode';
+ //SDateEncodeError = 'Invalid argument to date encode';
+ SOutOfMemory = 'Out of memory';
+ SInOutError = 'I/O error %d';
+ SFileNotFound = 'File not found';
+ SInvalidFilename = 'Invalid filename';
+ STooManyOpenFiles = 'Too many open files';
+ SAccessDenied = 'File access denied';
+ SEndOfFile = //'Read beyond end of file';
+ 'End of file';
+ SDiskFull = 'Disk full';
+ //SInvalidInput = 'Invalid numeric input'; // {-} Seems for console input only
+ SDivByZero = 'Division by zero';
+ SRangeError = 'Range check error';
+ SIntOverflow = 'Integer overflow';
+ SInvalidOp = 'Invalid floating point operation';
+ SZeroDivide = 'Floating point division by zero';
+ SOverflow = 'Floating point overflow';
+ SUnderflow = 'Floating point underflow';
+ SInvalidPointer = 'Invalid pointer operation';
+ SInvalidCast = 'Invalid class typecast';
+ SAccessViolation = 'Access violation at address %p. %s of address %p';
+ SStackOverflow = 'Stack overflow';
+ SControlC = //'Control-C hit';
+ '^C'; // {-} for console applications only
+ SPrivilege = 'Privileged instruction';
+ SOperationAborted = 'Operation aborted';
+ SException = 'Exception %s in module %s at %p.'#10'%s%s';
+ //SExceptTitle = 'Application Error';
+ //SInvalidFormat = 'Format ''%s'' invalid or incompatible with argument';
+ //SArgumentMissing = 'No argument for format ''%s''';
+ SInvalidVarCast = 'Invalid variant type conversion';
+ SInvalidVarOp = 'Invalid variant operation';
+ SDispatchError = 'Variant method calls not supported';
+ SVarArrayCreate = 'Error creating variant array';
+ SVarNotArray = 'Variant is not an array';
+ SVarArrayBounds = 'Variant array index out of bounds';
+ SVar = 'EVariant';
+ SReadAccess = 'Read';
+ SWriteAccess = 'Write';
+ //SResultTooLong = 'Format result longer than 4096 characters';
+ //SFormatTooLong = 'Format string too long';
+ SExternalException = 'External exception %x';
+ SAssertionFailed = 'Assertion failed';
+ SIntfCastError = 'Interface not supported';
+ SSafecallException = 'Exception in safecall method';
+ SAssertError = '%s (%s, line %d)';
+ SAbstractError = 'Abstract Error';
+ SModuleAccessViolation = 'Access violation at address %p in module ''%s''. %s of address %p';
+ {SCannotReadPackageInfo = 'Cannot access package information for package ''%s''';
+ sErrorLoadingPackage = 'Can''t load package %s.'#13#10'%s';
+ SInvalidPackageFile = 'Invalid package file ''%s''';
+ SInvalidPackageHandle = 'Invalid package handle';
+ SDuplicatePackageUnit = 'Cannot load package ''%s.'' It contains unit ''%s,''' +
+ ';which is also contained in package ''%s''';}
+ SWin32Error = 'Win32 Error. Code: %d.'#10'%s';
+ SUnkWin32Error = 'A Win32 API function failed';
+ SNL = 'Application is not licensed to use this feature';
+{-}
+
+type
+
+{ Generic procedure pointer }
+
+ TProcedure = procedure;
+
+{ Generic filename type }
+
+ TFileName = type string;
+
+{ Exceptions }
+ Exception = class;
+ TDestroyException = procedure( Sender: Exception ) of object;
+
+ TError = ( e_Abort, e_Heap, e_OutOfMem, e_InOut, e_External, e_Int,
+ e_DivBy0, e_Range, e_IntOverflow, e_Math, e_Math_InvalidArgument,
+ e_InvalidOp, e_ZeroDivide, e_Overflow, e_Underflow, e_InvalidPointer,
+ e_InvalidCast, e_Convert, e_AccessViolation, e_Privilege,
+ e_StackOverflow, e_CtrlC, e_Variant, e_PropReadOnly,
+ e_PropWriteOnly, e_Assertion, e_Abstract, e_IntfCast,
+ e_InvalidContainer, e_InvalidInsert, e_Package, e_Win32,
+ e_SafeCall, e_License, e_Custom, e_Com, e_Ole, e_Registry );
+ {* Main error codes. These are to determine which exception occure. You
+ can use e_Custom code for your own exceptions. }
+
+ Exception = class(TObject)
+ {* Exception class. In KOL, there is a single exception class is used.
+ Instead of inheriting new exception classes from this ancestor, an
+ instance of the same Exception class should be used. The difference
+ is only in Code property, which contains a kind of exception. }
+ protected
+ FCode: TError;
+ FErrorCode: DWORD;
+ FMessage: KOLString;
+ FExceptionRecord: PExceptionRecord;
+ FData: Pointer;
+ FOnDestroy: TDestroyException;
+ procedure SetData(const Value: Pointer);
+ public
+ constructor Create(ACode: TError; const Msg: string);
+ {* Use this constructor to raise exception, which does not require of
+ argument formatting. }
+ constructor CreateFmt(ACode: TError; const Msg: string; const Args: array of const);
+ {* Use this constructor to raise an exception with formatted Message string.
+ Take into attention, that Format procedure defined in KOL, uses API wvsprintf
+ function, which can understand a restricted set of format specifications. }
+ constructor CreateCustom(AError: DWORD; const Msg: String);
+ {* Use this constructor to create e_Custom exception and to assign AError to
+ its ErrorCode property. }
+ constructor CreateCustomFmt(AError: DWORD; const Msg: String; const Args: array of const);
+ {* Use this constructor to create e_Custom exception with formatted message
+ string and to assign AError to its ErrorCode property. }
+ constructor CreateResFmt(ACode: TError; Ident: Integer; const Args: array of const);
+ {* }
+ destructor Destroy; override;
+ {* destructor }
+ property Message: KOLString read FMessage; // write FMessage;
+ {* Text string, containing descriptive message about the exception. }
+ property Code: TError read FCode;
+ {* Main exception code. This property can be used to determine, which exception
+ occure. }
+ property ErrorCode: DWORD read FErrorCode write FErrorCode;
+ {* This code is to detailize error. For Code = e_InOut, ErrorCode contains
+ more detail description of input/output error. For e_Custom, You can
+ assign it to any value You want. }
+ property ExceptionRecord: PExceptionRecord read FExceptionRecord;
+ {* This property is only for e_External exception. }
+ property Data: Pointer read FData write SetData;
+ {* Custom defined pointer. Use it in your custom exceptions. }
+ property OnDestroy: TDestroyException read FOnDestroy write FOnDestroy;
+ {* This event is to allow to do something when custom Exception is
+ released. }
+ end;
+ {*
+ With err unit, it is possible to use all capabilities of Delphi exception
+ handling almost in the same way as usual. The difference only in that the
+ single exception class should be used. To determine which exception occure,
+ use property Code. So, code to handle exception can be written like follow:
+ ! try
+ ! ...
+ ! except on E: Exception do
+ ! case E.Code of
+ ! e_DivBy0: HandleDivideByZero;
+ ! e_Overflow: HandleOverflow;
+ ! ...
+ ! end;
+ ! end;
+ To raise an error, create an instance of Exception class object, but
+ pass a Code to its constructor:
+ ! var E: Exception;
+ ! ...
+ ! E := Exception.Create( e_Custom, 'My custom exception' );
+ ! E.ErrorCode := MY_MAGIC_CODE_FOR_CUSTOM_EXCEPTION;
+ ! raise E;
+ }
+
+ ExceptClass = class of Exception;
+
+{ Exit procedure handling }
+
+{ AddExitProc adds the given procedure to the run-time library's exit
+ procedure list. When an application terminates, its exit procedures are
+ executed in reverse order of definition, i.e. the last procedure passed
+ to AddExitProc is the first one to get executed upon termination. }
+
+procedure AddExitProc(Proc: TProcedure);
+
+{ System error messages }
+
+function SysErrorMessage(ErrorCode: Integer): string;
+
+{ Exception handling routines }
+
+function ExceptObject: TObject;
+function ExceptAddr: Pointer;
+
+function ExceptionErrorMessage(ExceptObject: TObject; ExceptAddr: Pointer;
+ Buffer: PKOLChar; Size: Integer): Integer;
+
+procedure ShowException(ExceptObject: TObject; ExceptAddr: Pointer);
+
+procedure Abort;
+
+//procedure OutOfMemoryError;
+
+{ RaiseLastWin32Error calls the GetLastError API to retrieve the code for }
+{ the last occuring Win32 error. If GetLastError returns an error code, }
+{ RaiseLastWin32Error then raises an exception with the error code and }
+{ message associated with with error. }
+
+procedure RaiseLastWin32Error;
+
+{ Win32Check is used to check the return value of a Win32 API function }
+{ which returns a BOOL to indicate success. If the Win32 API function }
+{ returns False (indicating failure), Win32Check calls RaiseLastWin32Error }
+{ to raise an exception. If the Win32 API function returns True, }
+{ Win32Check returns True. }
+
+function Win32Check(RetVal: BOOL): BOOL;
+
+{ Termination procedure support }
+
+type
+ TTerminateProc = function: Boolean;
+
+{ Call AddTerminateProc to add a terminate procedure to the system list of }
+{ termination procedures. Delphi will call all of the function in the }
+{ termination procedure list before an application terminates. The user- }
+{ defined TermProc function should return True if the application can }
+{ safely terminate or False if the application cannot safely terminate. }
+{ If one of the functions in the termination procedure list returns False, }
+{ the application will not terminate. }
+
+procedure AddTerminateProc(TermProc: TTerminateProc);
+
+{ CallTerminateProcs is called by VCL when an application is about to }
+{ terminate. It returns True only if all of the functions in the }
+{ system's terminate procedure list return True. This function is }
+{ intended only to be called by Delphi, and it should not be called }
+{ directly. }
+
+function CallTerminateProcs: Boolean;
+
+{$IFNDEF _D2}
+function GDAL: LongWord;
+procedure RCS;
+procedure RPR;
+{$ENDIF}
+
+
+{ SafeLoadLibrary calls LoadLibrary, disabling normal Win32 error message
+ popup dialogs if the requested file can't be loaded. SafeLoadLibrary also
+ preserves the current FPU control word (precision, exception masks) across
+ the LoadLibrary call (in case the DLL you're loading hammers the FPU control
+ word in its initialization, as many MS DLLs do)}
+
+{$IFNDEF _D2orD3}
+function SafeLoadLibrary(const Filename: KOLString;
+ ErrorMode: UINT = SEM_NOOPENFILEERRORBOX): HMODULE;
+{$ENDIF}
+
+implementation
+
+{procedure ConvertError(const Ident: string);
+begin
+ raise Exception.Create(e_Convert, Ident);
+end;
+
+procedure ConvertErrorFmt(ResString: PResStringRec; const Args: array of const);
+begin
+ raise Exception.CreateFmt(e_Convert, LoadResString(ResString), Args);
+end;}
+
+{ Memory management routines }
+
+function AllocMem(Size: Cardinal): Pointer;
+begin
+ GetMem(Result, Size);
+ FillChar(Result^, Size, 0);
+end;
+
+{ Exit procedure handling }
+
+type
+ PExitProcInfo = ^TExitProcInfo;
+ TExitProcInfo = record
+ Next: PExitProcInfo;
+ SaveExit: Pointer;
+ Proc: TProcedure;
+ end;
+
+var
+ ExitProcList: PExitProcInfo = nil;
+
+procedure DoExitProc;
+var
+ P: PExitProcInfo;
+ Proc: TProcedure;
+begin
+ P := ExitProcList;
+ ExitProcList := P^.Next;
+ ExitProc := P^.SaveExit;
+ Proc := P^.Proc;
+ Dispose(P);
+ Proc;
+end;
+
+procedure AddExitProc(Proc: TProcedure);
+var
+ P: PExitProcInfo;
+begin
+ New(P);
+ P^.Next := ExitProcList;
+ P^.SaveExit := ExitProc;
+ P^.Proc := Proc;
+ ExitProcList := P;
+ ExitProc := @DoExitProc;
+end;
+
+{ System error messages }
+
+function SysErrorMessage(ErrorCode: Integer): string;
+var
+ Len: Integer;
+ Buffer: array[0..255] of KOLChar;
+begin
+ Len := FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or
+ FORMAT_MESSAGE_ARGUMENT_ARRAY, nil, ErrorCode, 0, Buffer,
+ SizeOf(Buffer), nil);
+ while (Len > 0) and ((Buffer[Len - 1] <= ' ') or
+ (Buffer[Len - 1] = '.')) do Dec(Len);
+ SetString(Result, Buffer, Len);
+end;
+
+{ Exception handling routines }
+
+{var
+ OutOfMemory: EOutOfMemory;
+ InvalidPointer: EInvalidPointer;}
+
+type
+ PRaiseFrame = ^TRaiseFrame;
+ TRaiseFrame = record
+ NextRaise: PRaiseFrame;
+ ExceptAddr: Pointer;
+ ExceptObject: TObject;
+ ExceptionRecord: PExceptionRecord;
+ end;
+
+{ Return current exception object }
+
+function ExceptObject: TObject;
+begin
+ if RaiseList <> nil then
+ Result := PRaiseFrame(RaiseList)^.ExceptObject else
+ Result := nil;
+end;
+
+{ Return current exception address }
+
+function ExceptAddr: Pointer;
+begin
+ if RaiseList <> nil then
+ Result := PRaiseFrame(RaiseList)^.ExceptAddr else
+ Result := nil;
+end;
+
+{ Convert physical address to logical address }
+
+function ConvertAddr(Address: Pointer): Pointer; assembler;
+asm
+ TEST EAX,EAX { Always convert nil to nil }
+ JE @@1
+ SUB EAX, $1000 { offset from code start; code start set by linker to $1000 }
+@@1:
+end;
+
+{ Format and return an exception error message }
+
+{$IFDEF _D2} // this code is luck in D2 system.pas
+{type
+ PLibModule = ^TLibModule;
+ TLibModule = record
+ Next: PLibModule;
+ Instance: Longint;
+ ResInstance: Longint;
+ Reserved: Integer;
+ end;}
+
+function FindResourceHInstance(Instance: Longint): Longint;
+begin
+ Result := Instance;
+end;
+{$ENDIF}
+
+type
+ PStrData = ^TStrData;
+ TStrData = record
+ Ident: Integer;
+ Buffer: PKOLChar;
+ BufSize: Integer;
+ nChars: Integer;
+ end;
+
+function EnumStringModules(Instance: THANDLE; Data: Pointer): Boolean;
+begin
+ with PStrData(Data)^ do
+ begin
+ nChars := LoadString(Instance, Ident, Buffer, BufSize);
+ Result := nChars = 0;
+ end;
+end;
+
+{$IFNDEF _D2}
+function FindStringResource(Ident: Integer; Buffer: PKOLChar; BufSize: Integer): Integer;
+var
+ StrData: TStrData;
+begin
+ StrData.Ident := Ident;
+ StrData.Buffer := Buffer;
+ StrData.BufSize := BufSize;
+ StrData.nChars := 0;
+ EnumResourceModules(EnumStringModules, @StrData);
+ Result := StrData.nChars;
+end;
+{$ENDIF}
+
+{$IFDEF _D2}
+function LoadStr(Ident: Integer): string;
+var
+ Buffer: array[0..1023] of Char;
+begin
+ SetString(Result, Buffer, LoadString(HInstance, Ident, Buffer,
+ SizeOf(Buffer)));
+end;
+{$ELSE}
+function LoadStr(Ident: Integer): string;
+var
+ Buffer: array[0..1023] of KOLChar;
+begin
+ SetString(Result, Buffer, FindStringResource(Ident, Buffer, SizeOf(Buffer)));
+end;
+{$ENDIF}
+
+function FmtLoadStr(Ident: Integer; const Args: array of const): string;
+begin
+ //FmtStr(Result, LoadStr(Ident), Args);
+ Result := Format(LoadStr(Ident), Args);
+end;
+
+function ExceptionErrorMessage(ExceptObject: TObject; ExceptAddr: Pointer;
+ Buffer: PKOLChar; Size: Integer): Integer;
+var
+ ex: Exception;
+ MsgPtr: PKOLChar;
+ //MsgEnd: PChar;
+ //MsgLen: Integer;
+ ModuleName: array[0..MAX_PATH] of KOLChar;
+ //Temp: array[0..MAX_PATH] of Char;
+ Fmt: array[0..255] of KOLChar;
+ Info: TMemoryBasicInformation;
+ ConvertedAddress: Pointer;
+begin
+ VirtualQuery(ExceptAddr, Info, sizeof(Info));
+ if (Info.State <> MEM_COMMIT) or
+ (GetModuleFilename( THandle(Info.AllocationBase), {Temp} ModuleName,
+ SizeOf({Temp} ModuleName)) = 0) then
+ begin
+ GetModuleFileName(HInstance, {Temp} ModuleName, SizeOf({Temp} ModuleName));
+ ConvertedAddress := ConvertAddr(ExceptAddr);
+ end
+ else
+ Integer(ConvertedAddress) := Integer(ExceptAddr) - Integer(Info.AllocationBase);
+ //StrLCopy(ModuleName, AnsiStrRScan(Temp, '\') + 1, SizeOf(ModuleName) - 1);
+ {-} // Why to extract unit name from a path? Isn't it well to show complete path
+ // and to economy code for the extraction.
+ MsgPtr := '';
+ //MsgEnd := '';
+ if ExceptObject is Exception then
+ begin
+ ex := Exception(ExceptObject);
+ MsgPtr := PKOLChar(ex.Message);
+ //MsgLen := StrLen(MsgPtr);
+ //if (MsgLen <> 0) and (MsgPtr[MsgLen - 1] <> '.') then MsgEnd := '.';
+ {-} // Isn't it too beautiful - devote ~40 bytes of code just to decide,
+ // add or not a point at the end of the message.
+ end;
+ {$IFNDEF USE_RESOURCESTRING}
+ {$IFDEF UNICODE_CTRLS} WStrCopy {$ELSE} StrCopy {$ENDIF}( Fmt, SException );
+ {$ELSE}
+ LoadString(FindResourceHInstance(HInstance),
+ PResStringRec(@SException).Identifier, Fmt, SizeOf(Fmt));
+ {$ENDIF}
+ //MsgOK( ModuleName );
+ {$IFDEF UNICODE_CTRLS} WStrCopy {$ELSE} StrCopy {$ENDIF}
+ ( Buffer, PKOLChar( Format( Fmt, [ ExceptObject.ClassName,
+ ModuleName, ConvertedAddress, MsgPtr, '' {MsgEnd}]) ) );
+ Result := {$IFDEF UNICODE_CTRLS} WStrLen {$ELSE} StrLen {$ENDIF}(Buffer);
+end;
+
+{ Display exception message box }
+
+procedure ShowException(ExceptObject: TObject; ExceptAddr: Pointer);
+var
+ Buffer: array[0..1023] of KOLChar;
+begin
+ ExceptionErrorMessage(ExceptObject, ExceptAddr, Buffer, SizeOf(Buffer));
+ {if IsConsole then
+ WriteLn(Buffer)
+ else}
+ begin
+ {LoadString(FindResourceHInstance(HInstance), PResStringRec(@SExceptTitle).Identifier,
+ Title, SizeOf(Title));}
+ MessageBox(0, Buffer, {Title} nil, MB_OK {or MB_ICONSTOP} or MB_SYSTEMMODAL);
+ end;
+end;
+
+{ Raise abort exception }
+
+procedure Abort;
+
+ function ReturnAddr: Pointer;
+ asm
+// MOV EAX,[ESP + 4] !!! codegen dependant
+ MOV EAX,[EBP - 4]
+ end;
+
+begin
+ raise Exception.Create(e_Abort, SOperationAborted) at ReturnAddr;
+end;
+
+{ Raise out of memory exception }
+
+{procedure OutOfMemoryError;
+begin
+ raise OutOfMemory;
+end;}
+
+{ Exception class }
+
+constructor Exception.CreateResFmt(ACode: TError; Ident: Integer;
+ const Args: array of const);
+begin
+ FMessage := Format(LoadStr(Ident), Args);
+end;
+
+destructor Exception.Destroy;
+begin
+ if Assigned( FOnDestroy ) then
+ FOnDestroy( Self );
+ inherited;
+end;
+
+procedure Exception.SetData(const Value: Pointer);
+begin
+ FData := Value;
+end;
+
+constructor Exception.Create(ACode: TError; const Msg: string);
+begin
+ FCode := ACode;
+ FMessage := Msg;
+ //FAllowFree := TRUE;
+end;
+
+constructor Exception.CreateCustom(AError: DWORD; const Msg: String);
+begin
+ FCode := e_Custom;
+ FMessage := Msg;
+ FErrorCode := AError;
+end;
+
+constructor Exception.CreateCustomFmt(AError: DWORD; const Msg: String;
+ const Args: array of const);
+begin
+ FCode := e_Custom;
+ FErrorCode := AError;
+ FMessage := Format(Msg, Args);
+end;
+
+constructor Exception.CreateFmt(ACode: TError; const Msg: string;
+ const Args: array of const);
+begin
+ FCode := ACode;
+ FMessage := Format(Msg, Args);
+end;
+
+{ EHeapException class }
+
+{procedure EHeapException.FreeInstance;
+begin
+ if AllowFree then
+ inherited FreeInstance;
+end;}
+
+{ Create I/O exception }
+
+function CreateInOutError: Exception;
+type
+ TErrorRec = record
+ Code: Integer;
+ Ident: string;
+ end;
+const
+ ErrorMap: array[0..5] of TErrorRec = (
+ (Code: 2; Ident: SFileNotFound),
+ (Code: 3; Ident: SInvalidFilename),
+ (Code: 4; Ident: STooManyOpenFiles),
+ (Code: 5; Ident: SAccessDenied),
+ (Code: 100; Ident: SEndOfFile),
+ (Code: 101; Ident: SDiskFull){,
+ (Code: 106; Ident: SInvalidInput)} );
+var
+ I: Integer;
+ InOutRes: Integer;
+begin
+ I := Low(ErrorMap);
+ InOutRes := IOResult; // resets IOResult to zero
+ while (I <= High(ErrorMap)) and (ErrorMap[I].Code <> InOutRes) do Inc(I);
+ if I <= High(ErrorMap) then
+ Result := Exception.Create(e_InOut, ErrorMap[I].Ident)
+ else
+ Result := Exception.CreateFmt(e_InOut, SInOutError, [InOutRes]);
+ //Result := Exception.Create(e_InOut, SInOutError + Int2Str( InOutRes ) );
+ Result.ErrorCode := InOutRes;
+end;
+
+{ RTL error handler }
+
+type
+ TExceptMapRec = packed record
+ ECode: TError;
+ EIdent: String;
+ end;
+
+const
+ ExceptMap: array[1..24] of TExceptMapRec = (
+ (ECode: e_OutOfMem; EIdent: SOutOfMemory),
+ (ECode: e_InvalidPointer; EIdent: SInvalidPointer),
+ (ECode: e_DivBy0; EIdent: SDivByZero),
+ (ECode: e_Range; EIdent: SRangeError),
+ (ECode: e_IntOverflow; EIdent: SIntOverflow),
+ (ECode: e_InvalidOp; EIdent: SInvalidOp),
+ (ECode: e_ZeroDivide; EIdent: SDivByZero),
+ (ECode: e_Overflow; EIdent: SOverflow),
+ (ECode: e_Underflow; EIdent: SUnderflow),
+ (ECode: e_InvalidCast; EIdent: SInvalidCast),
+ (ECode: e_AccessViolation;EIdent: SAccessViolation),
+ (ECode: e_Privilege; EIdent: SPrivilege),
+ (ECode: e_CtrlC; EIdent: SControlC),
+ // {-} Only for console applications
+ (ECode: e_StackOverflow; EIdent: SStackOverflow),
+ {$IFDEF VARIANT_USED}
+ (ECode: e_Variant; EIdent: SInvalidVarCast),
+ (ECode: e_Variant; EIdent: SInvalidVarOp),
+ (ECode: e_Variant; EIdent: SDispatchError),
+ (ECode: e_Variant; EIdent: SVarArrayCreate),
+ (ECode: e_Variant; EIdent: SVarNotArray),
+ (ECode: e_Variant; EIdent: SVarArrayBounds),
+ {$ELSE}
+ (ECode: e_Variant; EIdent: SVar),
+ (ECode: e_Variant; EIdent: SVar),
+ (ECode: e_Variant; EIdent: SVar),
+ (ECode: e_Variant; EIdent: SVar),
+ (ECode: e_Variant; EIdent: SVar),
+ (ECode: e_Variant; EIdent: SVar),
+ {$ENDIF}
+ (ECode: e_Assertion; EIdent: SAssertionFailed),
+ (ECode: e_External; EIdent: SExternalException),
+ (ECode: e_IntfCast; EIdent: SIntfCastError),
+ (ECode: e_SafeCall; EIdent: SSafecallException));
+
+procedure ErrorHandler(ErrorCode: Integer; ErrorAddr: Pointer);
+var
+ E: Exception;
+begin
+ {case ErrorCode of
+ 1: E := OutOfMemory;
+ 2: E := InvalidPointer;
+ 3..24: with ExceptMap[ErrorCode] do E := EClass.Create(EIdent);
+ else
+ E := CreateInOutError;
+ end;}
+
+ { + }
+ if ErrorCode <= 24 then
+ with ExceptMap[ErrorCode] do E := Exception.Create(ECode, EIdent)
+ else E := CreateInOutError;
+ { - }
+
+ raise E at ErrorAddr;
+end;
+
+{ Assertion error handler }
+
+{ This is complicated by the desire to make it look like the exception }
+{ happened in the user routine, so the debugger can give a decent stack }
+{ trace. To make that feasible, AssertErrorHandler calls a helper function }
+{ to create the exception object, so that AssertErrorHandler itself does }
+{ not need any temps. After the exception object is created, the asm }
+{ routine RaiseAssertException sets up the registers just as if the user }
+{ code itself had raised the exception. }
+
+function CreateAssertException(const Message, Filename: string;
+ LineNumber: Integer): Exception;
+var
+ S: string;
+begin
+ if Message <> '' then S := Message else S := SAssertionFailed;
+ Result := Exception.CreateFmt(e_Assertion, SAssertError,
+ [S, Filename, LineNumber]);
+end;
+
+{ This code is based on the following assumptions: }
+{ - Our direct caller (AssertErrorHandler) has an EBP frame }
+{ - ErrorStack points to where the return address would be if the }
+{ user program had called System.@RaiseExcept directly }
+procedure RaiseAssertException(const E: Exception; const ErrorAddr, ErrorStack: Pointer);
+asm
+ MOV ESP,ECX
+ MOV [ESP],EDX
+ MOV EBP,[EBP]
+ JMP System.@RaiseExcept
+end;
+
+{ If you change this procedure, make sure it does not have any local variables }
+{ or temps that need cleanup - they won't get cleaned up due to the way }
+{ RaiseAssertException frame works. Also, it can not have an exception frame. }
+procedure AssertErrorHandler(const Message, Filename: string;
+ LineNumber: Integer; ErrorAddr: Pointer);
+var
+ E: Exception;
+begin
+ E := CreateAssertException(Message, Filename, LineNumber);
+ RaiseAssertException(E, ErrorAddr, PChar(@ErrorAddr)+4);
+end;
+
+{ Abstract method invoke error handler }
+
+procedure AbstractErrorHandler;
+begin
+ raise Exception.Create(e_Abstract, SAbstractError);
+end;
+
+{$IFDEF ASM_VERSION}
+function MapException(P: PExceptionRecord): Byte;
+asm //cmd //opd
+ MOV EAX, [EAX].TExceptionRecord.ExceptionCode
+ SUB EAX, $C0000000
+ CMP EAX, $FD
+ JA @@code22
+
+ XOR ECX, ECX
+ MOV EDX, offset @@cvTable - 1
+@@loo:
+ INC EDX
+ MOV CL, [EDX]
+ JECXZ @@code22
+ INC EDX
+ CMP AL, [EDX]
+ JNE @@loo
+
+ MOV AL, CL
+ RET
+
+@@cvTable:
+ DB 3, $94
+ DB 4, $8C
+ DB 5, $95
+ DB 6, $8F, 6, $90, 6, $92
+ DB 7, $8E
+ DB 8, $91
+ DB 9, $8D, 9, $93
+ DB 11, $05
+ DB 12, $96
+ DB 14, $FD
+ DB 0
+
+@@code22:
+ MOV AL, 22
+end;
+{$ELSE} //Pascal
+function MapException(P: PExceptionRecord): Byte;
+begin
+ case P.ExceptionCode of
+ STATUS_INTEGER_DIVIDE_BY_ZERO:
+ Result := 3;
+ STATUS_ARRAY_BOUNDS_EXCEEDED:
+ Result := 4;
+ STATUS_INTEGER_OVERFLOW:
+ Result := 5;
+ STATUS_FLOAT_INEXACT_RESULT,
+ STATUS_FLOAT_INVALID_OPERATION,
+ STATUS_FLOAT_STACK_CHECK:
+ Result := 6;
+ STATUS_FLOAT_DIVIDE_BY_ZERO:
+ Result := 7;
+ STATUS_FLOAT_OVERFLOW:
+ Result := 8;
+ STATUS_FLOAT_UNDERFLOW,
+ STATUS_FLOAT_DENORMAL_OPERAND:
+ Result := 9;
+ STATUS_ACCESS_VIOLATION:
+ Result := 11;
+ STATUS_PRIVILEGED_INSTRUCTION:
+ Result := 12;
+ STATUS_CONTROL_C_EXIT:
+ Result := 13;
+ STATUS_STACK_OVERFLOW:
+ Result := 14;
+ else
+ Result := 22; { must match System.reExternalException }
+ end;
+end;
+{$ENDIF}
+
+function GetExceptionClass(P: PExceptionRecord): ExceptClass;
+//var ErrorCode: Byte;
+begin
+ //ErrorCode := MapException(P);
+ Result := Exception; {ExceptMap[ErrorCode].EClass;}
+end;
+
+function GetExceptionObject(P: PExceptionRecord): Exception;
+var
+ ErrorCode: Integer;
+
+ function CreateAVObject: Exception;
+ var
+ AccessOp: string; // string ID indicating the access type READ or WRITE
+ AccessAddress: Pointer;
+ MemInfo: TMemoryBasicInformation;
+ ModName: array[0..MAX_PATH] of KOLChar;
+ begin
+ with P^ do
+ begin
+ if ExceptionInformation[0] = 0 then
+ AccessOp := SReadAccess else
+ AccessOp := SWriteAccess;
+ AccessAddress := Pointer(ExceptionInformation[1]);
+ VirtualQuery(ExceptionAddress, MemInfo, SizeOf(MemInfo));
+ if (MemInfo.State = MEM_COMMIT) and (GetModuleFileName(THandle(MemInfo.AllocationBase),
+ ModName, SizeOf(ModName)) <> 0) then
+ Result := Exception.CreateFmt(e_AccessViolation, sModuleAccessViolation,
+ [ExceptionAddress, ExtractFileName(ModName), AccessOp,
+ AccessAddress])
+ else Result := Exception.CreateFmt(e_AccessViolation, sAccessViolation,
+ [ExceptionAddress, AccessOp, AccessAddress]);
+ end;
+ end;
+
+begin
+ ErrorCode := MapException(P);
+ case ErrorCode of
+ 3..10, 12..21:
+ with ExceptMap[ErrorCode] do Result := Exception.Create(ECode, EIdent);
+ 11: Result := CreateAVObject;
+ else
+ begin
+ Result := Exception.CreateFmt(e_External, SExternalException, [P.ExceptionCode]);
+ //Result.FExceptionRecord := P;
+ end;
+ end;
+ Result.FExceptionRecord := P;
+end;
+
+{ RTL exception handler }
+
+procedure ExceptHandler(ExceptObject: TObject; ExceptAddr: Pointer); far;
+begin
+ ShowException(ExceptObject, ExceptAddr);
+ Halt(1);
+end;
+
+{+}
+function InitAssertErrorProc: Boolean;
+begin
+ AssertErrorProc := @AssertErrorHandler;
+ Result := TRUE;
+end;
+{-}
+
+procedure InitExceptions;
+begin
+ {OutOfMemory := EOutOfMemory.Create(SOutOfMemory);
+ InvalidPointer := EInvalidPointer.Create(SInvalidPointer);}
+ ErrorProc := @ErrorHandler;
+ ExceptProc := @ExceptHandler;
+ ExceptionClass := Exception;
+
+ ExceptClsProc := @GetExceptionClass;
+
+ ExceptObjProc := @GetExceptionObject;
+
+ {AssertErrorProc := @AssertErrorHandler;}
+ {+} // Initialize Assert only when "Assertions" option is turned on in Compiler:
+ Assert( InitAssertErrorProc, '' );
+ {-}
+
+ //AbstractErrorProc := @AbstractErrorHandler;
+ // {-} KOL does not use classes, so EAbstractError should never be raised.
+
+end;
+
+procedure DoneExceptions;
+begin
+ {OutOfMemory.AllowFree := True;
+ OutOfMemory.FreeInstance;
+ OutOfMemory := nil;
+ InvalidPointer.AllowFree := True;
+ InvalidPointer.Free;
+ InvalidPointer := nil;}
+ ErrorProc := nil;
+ ExceptProc := nil;
+ ExceptionClass := nil;
+ //ExceptClsProc := nil; --see InitExceptions
+ ExceptObjProc := nil;
+ AssertErrorProc := nil;
+end;
+
+{ RaiseLastWin32Error }
+
+procedure RaiseLastWin32Error;
+var
+ LastError: DWORD;
+ Error: Exception;
+begin
+ LastError := GetLastError;
+ if LastError <> ERROR_SUCCESS then
+ Error := Exception.CreateFmt(e_Win32, SWin32Error, [LastError,
+ SysErrorMessage(LastError)])
+ else
+ Error := Exception.Create(e_Win32, SUnkWin32Error );
+ Error.ErrorCode := LastError;
+ raise Error;
+end;
+
+{ Win32Check }
+
+function Win32Check(RetVal: BOOL): BOOL;
+begin
+ if not RetVal then RaiseLastWin32Error;
+ Result := RetVal;
+end;
+
+type
+ PTerminateProcInfo = ^TTerminateProcInfo;
+ TTerminateProcInfo = record
+ Next: PTerminateProcInfo;
+ Proc: TTerminateProc;
+ end;
+
+var
+ TerminateProcList: PTerminateProcInfo = nil;
+
+procedure AddTerminateProc(TermProc: TTerminateProc);
+var
+ P: PTerminateProcInfo;
+begin
+ New(P);
+ P^.Next := TerminateProcList;
+ P^.Proc := TermProc;
+ TerminateProcList := P;
+end;
+
+function CallTerminateProcs: Boolean;
+var
+ PI: PTerminateProcInfo;
+begin
+ Result := True;
+ PI := TerminateProcList;
+ while Result and (PI <> nil) do
+ begin
+ Result := PI^.Proc;
+ PI := PI^.Next;
+ end;
+end;
+
+procedure FreeTerminateProcs;
+var
+ PI: PTerminateProcInfo;
+begin
+ while TerminateProcList <> nil do
+ begin
+ PI := TerminateProcList;
+ TerminateProcList := PI^.Next;
+ Dispose(PI);
+ end;
+end;
+
+{ --- }
+
+function AL1(const P): LongWord;
+asm
+ MOV EDX,DWORD PTR [P]
+ XOR EDX,DWORD PTR [P+4]
+ XOR EDX,DWORD PTR [P+8]
+ XOR EDX,DWORD PTR [P+12]
+ MOV EAX,EDX
+end;
+
+function AL2(const P): LongWord;
+asm
+ MOV EDX,DWORD PTR [P]
+ ROR EDX,5
+ XOR EDX,DWORD PTR [P+4]
+ ROR EDX,5
+ XOR EDX,DWORD PTR [P+8]
+ ROR EDX,5
+ XOR EDX,DWORD PTR [P+12]
+ MOV EAX,EDX
+end;
+
+const
+ AL1s: array[0..2] of LongWord = ($FFFFFFF0, $FFFFEBF0, 0);
+ AL2s: array[0..2] of LongWord = ($42C3ECEF, $20F7AEB6, $D1C2F74E);
+
+procedure ALV;
+begin
+ raise Exception.Create(e_License, SNL);
+end;
+
+{$IFNDEF _D2}
+function ALR: Pointer;
+var
+ LibModule: PLibModule;
+begin
+ if MainInstance <> 0 then
+ Result := Pointer(LoadResource(MainInstance, FindResource(MainInstance, 'DVCLAL',
+ PKOLChar( RT_RCDATA ))))
+ else
+ begin
+ Result := nil;
+ LibModule := LibModuleList;
+ while LibModule <> nil do
+ begin
+ with LibModule^ do
+ begin
+ Result := Pointer(LoadResource(Instance, FindResource(Instance, 'DVCLAL',
+ PKOLChar( RT_RCDATA ))));
+ if Result <> nil then Break;
+ end;
+ LibModule := LibModule.Next;
+ end;
+ end;
+ if Result = nil then ALV;
+end;
+
+function GDAL: LongWord;
+type
+ TDVCLAL = array[0..3] of LongWord;
+ PDVCLAL = ^TDVCLAL;
+var
+ P: Pointer;
+ A1, A2: LongWord;
+ PAL1s, PAL2s: PDVCLAL;
+ ALOK: Boolean;
+begin
+ P := ALR;
+ A1 := AL1(P^);
+ A2 := AL2(P^);
+ Result := A1;
+ PAL1s := @AL1s;
+ PAL2s := @AL2s;
+ ALOK := ((A1 = PAL1s[0]) and (A2 = PAL2s[0])) or
+ ((A1 = PAL1s[1]) and (A2 = PAL2s[1])) or
+ ((A1 = PAL1s[2]) and (A2 = PAL2s[2]));
+ FreeResource(Integer(P));
+ if not ALOK then ALV;
+end;
+
+procedure RCS;
+var
+ P: Pointer;
+ ALOK: Boolean;
+begin
+ P := ALR;
+ ALOK := (AL1(P^) = AL1s[2]) and (AL2(P^) = AL2s[2]);
+ FreeResource(Integer(P));
+ if not ALOK then ALV;
+end;
+
+procedure RPR;
+var
+ AL: LongWord;
+begin
+ AL := GDAL;
+ if (AL <> AL1s[1]) and (AL <> AL1s[2]) then ALV;
+end;
+{$ENDIF}
+
+{$IFNDEF _D2orD3}
+function SafeLoadLibrary(const Filename: KOLString; ErrorMode: UINT): HMODULE;
+var
+ OldMode: UINT;
+ FPUControlWord: Word;
+begin
+ OldMode := SetErrorMode(ErrorMode);
+ try
+ asm
+ FNSTCW FPUControlWord
+ end;
+ try
+ Result := LoadLibrary(PKOLChar(Filename));
+ finally
+ asm
+ FNCLEX
+ FLDCW FPUControlWord
+ end;
+ end;
+ finally
+ SetErrorMode(OldMode);
+ end;
+end;
+{$ENDIF}
+
+{procedure Exception.FreeInstance;
+begin
+ if FAllowFree then
+ inherited;
+end;}
+
+
+
+initialization
+ InitExceptions;
+
+finalization
+ FreeTerminateProcs;
+ DoneExceptions;
+
+end.
+
|