err.pas

   1 {$DEFINE ASM_VERSION}
   2 //{$DEFINE VARIANT_USED}
   3
   4 {$IFDEF ASM_VERSION}
   5   {$IFDEF PAS_VERSION}
   6     {$UNDEF ASM_VERSION}
   7   {$ENDIF}
   8 {$ENDIF}
   9
  10 {=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  11
  12         KKKKK    KKKKK    OOOOOOOOO    LLLLL
  13         KKKKK    KKKKK  OOOOOOOOOOOOO  LLLLL
  14         KKKKK    KKKKK  OOOOO   OOOOO  LLLLL
  15         KKKKK  KKKKK    OOOOO   OOOOO  LLLLL
  16         KKKKKKKKKK      OOOOO   OOOOO  LLLLL
  17         KKKKK  KKKKK    OOOOO   OOOOO  LLLLL
  18         KKKKK    KKKKK  OOOOO   OOOOO  LLLLL
  19         KKKKK    KKKKK  OOOOOOOOOOOOO  LLLLLLLLLLLLL
  20         KKKKK    KKKKK    OOOOOOOOO    LLLLLLLLLLLLL
  21
  22   Key Objects Library (C) 2000 by Kladov Vladimir.
  23
  24   mailto: bonanzas@xcl.cjb.net
  25   Home: http://kol.nm.ru
  26         http://xcl.cjb.net
  27         http://xcl.nm.ru
  28
  29  =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-}
  30 {
  31   This code is grabbed mainly from standard SysUtils.pas unit,
  32   provided by Borland Delphi. This unit is for handling exceptions,
  33   and to use it just place a reference to exceptions unit in
  34   uses clause of any of your unit or dpr-file.
  35 }
  36
  37 {       Copyright (C) 1995,99 Inprise Corporation       }
  38 {       Copyright (C) 2001, Kladov Vladimir             }
  39
  40 unit err;
  41 {* Unit to provide error handling for KOL programs using efficient
  42    exceptions mechanism. To use it, just place a reference to it into
  43    uses clause of any unit of the project (or dpr-file).
  44    |<br><br>
  45    It is possible to use standard SysUtils instead, but it increases
  46    size of executable at least by 10K. Using this unit to handle exceptions
  47    increases executable only by 6,5K.
  48 }
  49
  50 interface
  51
  52 uses Windows, KOL;
  53
  54 {$I KOLDEF.INC}
  55 {$IFDEF _D6orHigher}
  56   {$WARN SYMBOL_DEPRECATED OFF}
  57 {$ENDIF}
  58 {$IFDEF _D7orHigher}
  59   {$WARN UNSAFE_TYPE OFF}
  60   {$WARN UNSAFE_CODE OFF}
  61 {$ENDIF}
  62
  63 {+} // These resource strings are grabbed from SysConst and changed a bit to make it smaller.
  64
  65 {$IFDEF _D2orD3}
  66 type
  67   LongWord = DWORD;
  68 const
  69 {$ELSE}
  70 resourcestring
  71 {$ENDIF}
  72   SUnknown = '<unknown>';
  73   //SInvalidInteger = '''%s'' is not a valid integer value';
  74   //SInvalidFloat = '''%s'' is not a valid floating point value';
  75   //SInvalidDate = '''%s'' is not a valid date';
  76   //SInvalidTime = '''%s'' is not a valid time';
  77   //SInvalidDateTime = '''%s'' is not a valid date and time';
  78   //STimeEncodeError = 'Invalid argument to time encode';
  79   //SDateEncodeError = 'Invalid argument to date encode';
  80   SOutOfMemory = 'Out of memory';
  81   SInOutError = 'I/O error %d';
  82   SFileNotFound = 'File not found';
  83   SInvalidFilename = 'Invalid filename';
  84   STooManyOpenFiles = 'Too many open files';
  85   SAccessDenied = 'File access denied';
  86   SEndOfFile = //'Read beyond end of file';
  87                'End of file';
  88   SDiskFull = 'Disk full';
  89   //SInvalidInput = 'Invalid numeric input'; // {-} Seems for console input only
  90   SDivByZero = 'Division by zero';
  91   SRangeError = 'Range check error';
  92   SIntOverflow = 'Integer overflow';
  93   SInvalidOp = 'Invalid floating point operation';
  94   SZeroDivide = 'Floating point division by zero';
  95   SOverflow = 'Floating point overflow';
  96   SUnderflow = 'Floating point underflow';
  97   SInvalidPointer = 'Invalid pointer operation';
  98   SInvalidCast = 'Invalid class typecast';
  99   SAccessViolation = 'Access violation at address %p. %s of address %p';
 100   SStackOverflow = 'Stack overflow';
 101   SControlC = //'Control-C hit';
 102               '^C'; // {-} for console applications only
 103   SPrivilege = 'Privileged instruction';
 104   SOperationAborted = 'Operation aborted';
 105   SException = 'Exception %s in module %s at %p.'#10'%s%s';
 106   //SExceptTitle = 'Application Error';
 107   //SInvalidFormat = 'Format ''%s'' invalid or incompatible with argument';
 108   //SArgumentMissing = 'No argument for format ''%s''';
 109   SInvalidVarCast = 'Invalid variant type conversion';
 110   SInvalidVarOp = 'Invalid variant operation';
 111   SDispatchError = 'Variant method calls not supported';
 112   SVarArrayCreate = 'Error creating variant array';
 113   SVarNotArray = 'Variant is not an array';
 114   SVarArrayBounds = 'Variant array index out of bounds';
 115   SVar = 'EVariant';
 116   SReadAccess = 'Read';
 117   SWriteAccess = 'Write';
 118   //SResultTooLong = 'Format result longer than 4096 characters';
 119   //SFormatTooLong = 'Format string too long';
 120   SExternalException = 'External exception %x';
 121   SAssertionFailed = 'Assertion failed';
 122   SIntfCastError = 'Interface not supported';
 123   SSafecallException = 'Exception in safecall method';
 124   SAssertError = '%s (%s, line %d)';
 125   SAbstractError = 'Abstract Error';
 126   SModuleAccessViolation = 'Access violation at address %p in module ''%s''. %s of address %p';
 127   {SCannotReadPackageInfo = 'Cannot access package information for package ''%s''';
 128   sErrorLoadingPackage = 'Can''t load package %s.'#13#10'%s';
 129   SInvalidPackageFile = 'Invalid package file ''%s''';
 130   SInvalidPackageHandle = 'Invalid package handle';
 131   SDuplicatePackageUnit = 'Cannot load package ''%s.''  It contains unit ''%s,''' +
 132     ';which is also contained in package ''%s''';}
 133   SWin32Error = 'Win32 Error.  Code: %d.'#10'%s';
 134   SUnkWin32Error = 'A Win32 API function failed';
 135   SNL = 'Application is not licensed to use this feature';
 136 {-}
 137
 138 type
 139
 140 { Generic procedure pointer }
 141
 142   TProcedure = procedure;
 143
 144 { Generic filename type }
 145
 146   TFileName = type string;
 147
 148 { Exceptions }
 149   Exception = class;
 150   TDestroyException = procedure( Sender: Exception ) of object;
 151
 152   TError = ( e_Abort, e_Heap, e_OutOfMem, e_InOut, e_External, e_Int,
 153              e_DivBy0, e_Range, e_IntOverflow, e_Math, e_Math_InvalidArgument,
 154              e_InvalidOp, e_ZeroDivide, e_Overflow, e_Underflow, e_InvalidPointer,
 155              e_InvalidCast, e_Convert, e_AccessViolation, e_Privilege,
 156              e_StackOverflow, e_CtrlC, e_Variant, e_PropReadOnly,
 157              e_PropWriteOnly, e_Assertion, e_Abstract, e_IntfCast,
 158              e_InvalidContainer, e_InvalidInsert, e_Package, e_Win32,
 159              e_SafeCall, e_License, e_Custom, e_Com, e_Ole, e_Registry );
 160   {* Main error codes. These are to determine which exception occure. You
 161      can use e_Custom code for your own exceptions. }
 162
 163   Exception = class(TObject)
 164   {* Exception class. In KOL, there is a single exception class is used.
 165      Instead of inheriting new exception classes from this ancestor, an
 166      instance of the same Exception class should be used. The difference
 167      is only in Code property, which contains a kind of exception.  }
 168   protected
 169     FCode: TError;
 170     FErrorCode: DWORD;
 171     FMessage: string;
 172     FExceptionRecord: PExceptionRecord;
 173     FData: Pointer;
 174     FOnDestroy: TDestroyException;
 175     procedure SetData(const Value: Pointer);
 176   public
 177     constructor Create(ACode: TError; const Msg: string);
 178     {* Use this constructor to raise exception, which does not require of
 179        argument formatting. }
 180     constructor CreateFmt(ACode: TError; const Msg: string; const Args: array of const);
 181     {* Use this constructor to raise an exception with formatted Message string.
 182        Take into attention, that Format procedure defined in KOL, uses API wvsprintf
 183        function, which can understand a restricted set of format specifications. }
 184     constructor CreateCustom(AError: DWORD; const Msg: String);
 185     {* Use this constructor to create e_Custom exception and to assign AError to
 186        its ErrorCode property. }
 187     constructor CreateCustomFmt(AError: DWORD; const Msg: String; const Args: array of const);
 188     {* Use this constructor to create e_Custom exception with formatted message
 189        string and to assign AError to its ErrorCode property. }
 190     constructor CreateResFmt(ACode: TError; Ident: Integer; const Args: array of const);
 191     {* }
 192     destructor Destroy; override;
 193     {* destructor }
 194     property Message: string read FMessage; // write FMessage;
 195     {* Text string, containing descriptive message about the exception. }
 196     property Code: TError read FCode;
 197     {* Main exception code. This property can be used to determine, which exception
 198        occure. }
 199     property ErrorCode: DWORD read FErrorCode write FErrorCode;
 200     {* This code is to detailize error. For Code = e_InOut, ErrorCode contains
 201        more detail description of input/output error. For e_Custom, You can
 202        assign it to any value You want. }
 203     property ExceptionRecord: PExceptionRecord read FExceptionRecord;
 204     {* This property is only for e_External exception. }
 205     property Data: Pointer read FData write SetData;
 206     {* Custom defined pointer. Use it in your custom exceptions. }
 207     property OnDestroy: TDestroyException read FOnDestroy write FOnDestroy;
 208     {* This event is to allow to do something when custom Exception is
 209        released. }
 210   end;
 211   {*
 212     With err unit, it is possible to use all capabilities of Delphi exception
 213     handling almost in the same way as usual. The difference only in that the
 214     single exception class should be used. To determine which exception occure,
 215     use property Code. So, code to handle exception can be written like follow:
 216     ! try
 217     ! ...
 218     ! except on E: Exception do
 219     !   case E.Code of
 220     !   e_DivBy0: HandleDivideByZero;
 221     !   e_Overflow: HandleOverflow;
 222     !   ...
 223     !   end;
 224     ! end;
 225     To raise an error, create an instance of Exception class object, but
 226     pass a Code to its constructor:
 227     ! var E: Exception;
 228     ! ...
 229     ! E := Exception.Create( e_Custom, 'My custom exception' );
 230     ! E.ErrorCode := MY_MAGIC_CODE_FOR_CUSTOM_EXCEPTION;
 231     ! raise E;
 232   }
 233
 234   ExceptClass = class of Exception;
 235
 236 { Exit procedure handling }
 237
 238 { AddExitProc adds the given procedure to the run-time library's exit
 239   procedure list. When an application terminates, its exit procedures are
 240   executed in reverse order of definition, i.e. the last procedure passed
 241   to AddExitProc is the first one to get executed upon termination. }
 242
 243 procedure AddExitProc(Proc: TProcedure);
 244
 245 { System error messages }
 246
 247 function SysErrorMessage(ErrorCode: Integer): string;
 248
 249 { Exception handling routines }
 250
 251 function ExceptObject: TObject;
 252 function ExceptAddr: Pointer;
 253
 254 function ExceptionErrorMessage(ExceptObject: TObject; ExceptAddr: Pointer;
 255   Buffer: PChar; Size: Integer): Integer;
 256
 257 procedure ShowException(ExceptObject: TObject; ExceptAddr: Pointer);
 258
 259 procedure Abort;
 260
 261 //procedure OutOfMemoryError;
 262
 263 { RaiseLastWin32Error calls the GetLastError API to retrieve the code for }
 264 { the last occuring Win32 error.  If GetLastError returns an error code,  }
 265 { RaiseLastWin32Error then raises an exception with the error code and    }
 266 { message associated with with error. }
 267
 268 procedure RaiseLastWin32Error;
 269
 270 { Win32Check is used to check the return value of a Win32 API function     }
 271 { which returns a BOOL to indicate success.  If the Win32 API function     }
 272 { returns False (indicating failure), Win32Check calls RaiseLastWin32Error }
 273 { to raise an exception.  If the Win32 API function returns True,          }
 274 { Win32Check returns True. }
 275
 276 function Win32Check(RetVal: BOOL): BOOL;
 277
 278 { Termination procedure support }
 279
 280 type
 281   TTerminateProc = function: Boolean;
 282
 283 { Call AddTerminateProc to add a terminate procedure to the system list of }
 284 { termination procedures.  Delphi will call all of the function in the     }
 285 { termination procedure list before an application terminates.  The user-  }
 286 { defined TermProc function should return True if the application can      }
 287 { safely terminate or False if the application cannot safely terminate.    }
 288 { If one of the functions in the termination procedure list returns False, }
 289 { the application will not terminate. }
 290
 291 procedure AddTerminateProc(TermProc: TTerminateProc);
 292
 293 { CallTerminateProcs is called by VCL when an application is about to }
 294 { terminate.  It returns True only if all of the functions in the     }
 295 { system's terminate procedure list return True.  This function is    }
 296 { intended only to be called by Delphi, and it should not be called   }
 297 { directly. }
 298
 299 function CallTerminateProcs: Boolean;
 300
 301 {$IFNDEF _D2}
 302 function GDAL: LongWord;
 303 procedure RCS;
 304 procedure RPR;
 305 {$ENDIF}
 306
 307
 308 { SafeLoadLibrary calls LoadLibrary, disabling normal Win32 error message
 309   popup dialogs if the requested file can't be loaded.  SafeLoadLibrary also
 310   preserves the current FPU control word (precision, exception masks) across
 311   the LoadLibrary call (in case the DLL you're loading hammers the FPU control
 312   word in its initialization, as many MS DLLs do)}
 313
 314 {$IFNDEF _D2orD3}
 315 function SafeLoadLibrary(const Filename: string;
 316   ErrorMode: UINT = SEM_NOOPENFILEERRORBOX): HMODULE;
 317 {$ENDIF}
 318
 319 implementation
 320
 321 {procedure ConvertError(const Ident: string);
 322 begin
 323   raise Exception.Create(e_Convert, Ident);
 324 end;
 325
 326 procedure ConvertErrorFmt(ResString: PResStringRec; const Args: array of const);
 327 begin
 328   raise Exception.CreateFmt(e_Convert, LoadResString(ResString), Args);
 329 end;}
 330
 331 { Memory management routines }
 332
 333 function AllocMem(Size: Cardinal): Pointer;
 334 begin
 335   GetMem(Result, Size);
 336   FillChar(Result^, Size, 0);
 337 end;
 338
 339 { Exit procedure handling }
 340
 341 type
 342   PExitProcInfo = ^TExitProcInfo;
 343   TExitProcInfo = record
 344     Next: PExitProcInfo;
 345     SaveExit: Pointer;
 346     Proc: TProcedure;
 347   end;
 348
 349 var
 350   ExitProcList: PExitProcInfo = nil;
 351
 352 procedure DoExitProc;
 353 var
 354   P: PExitProcInfo;
 355   Proc: TProcedure;
 356 begin
 357   P := ExitProcList;
 358   ExitProcList := P^.Next;
 359   ExitProc := P^.SaveExit;
 360   Proc := P^.Proc;
 361   Dispose(P);
 362   Proc;
 363 end;
 364
 365 procedure AddExitProc(Proc: TProcedure);
 366 var
 367   P: PExitProcInfo;
 368 begin
 369   New(P);
 370   P^.Next := ExitProcList;
 371   P^.SaveExit := ExitProc;
 372   P^.Proc := Proc;
 373   ExitProcList := P;
 374   ExitProc := @DoExitProc;
 375 end;
 376
 377 { System error messages }
 378
 379 function SysErrorMessage(ErrorCode: Integer): string;
 380 var
 381   Len: Integer;
 382   Buffer: array[0..255] of Char;
 383 begin
 384   Len := FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or
 385     FORMAT_MESSAGE_ARGUMENT_ARRAY, nil, ErrorCode, 0, Buffer,
 386     SizeOf(Buffer), nil);
 387   while (Len > 0) and (Buffer[Len - 1] in [#0..#32, '.']) do Dec(Len);
 388   SetString(Result, Buffer, Len);
 389 end;
 390
 391 { Exception handling routines }
 392
 393 {var
 394   OutOfMemory: EOutOfMemory;
 395   InvalidPointer: EInvalidPointer;}
 396
 397 type
 398   PRaiseFrame = ^TRaiseFrame;
 399   TRaiseFrame = record
 400     NextRaise: PRaiseFrame;
 401     ExceptAddr: Pointer;
 402     ExceptObject: TObject;
 403     ExceptionRecord: PExceptionRecord;
 404   end;
 405
 406 { Return current exception object }
 407
 408 function ExceptObject: TObject;
 409 begin
 410   if RaiseList <> nil then
 411     Result := PRaiseFrame(RaiseList)^.ExceptObject else
 412     Result := nil;
 413 end;
 414
 415 { Return current exception address }
 416
 417 function ExceptAddr: Pointer;
 418 begin
 419   if RaiseList <> nil then
 420     Result := PRaiseFrame(RaiseList)^.ExceptAddr else
 421     Result := nil;
 422 end;
 423
 424 { Convert physical address to logical address }
 425
 426 function ConvertAddr(Address: Pointer): Pointer; assembler;
 427 asm
 428         TEST    EAX,EAX         { Always convert nil to nil }
 429         JE      @@1
 430         SUB     EAX, $1000      { offset from code start; code start set by linker to $1000 }
 431 @@1:
 432 end;
 433
 434 { Format and return an exception error message }
 435
 436 {$IFDEF _D2} // this code is luck in D2 system.pas
 437 {type
 438   PLibModule = ^TLibModule;
 439   TLibModule = record
 440     Next: PLibModule;
 441     Instance: Longint;
 442     ResInstance: Longint;
 443     Reserved: Integer;
 444   end;}
 445
 446 function FindResourceHInstance(Instance: Longint): Longint;
 447 begin
 448   Result := Instance;
 449 end;
 450 {$ENDIF}
 451
 452 type
 453   PStrData = ^TStrData;
 454   TStrData = record
 455     Ident: Integer;
 456     Buffer: PChar;
 457     BufSize: Integer;
 458     nChars: Integer;
 459   end;
 460
 461 function EnumStringModules(Instance: Longint; Data: Pointer): Boolean;
 462 begin
 463   with PStrData(Data)^ do
 464   begin
 465     nChars := LoadString(Instance, Ident, Buffer, BufSize);
 466     Result := nChars = 0;
 467   end;
 468 end;
 469
 470 {$IFNDEF _D2}
 471 function FindStringResource(Ident: Integer; Buffer: PChar; BufSize: Integer): Integer;
 472 var
 473   StrData: TStrData;
 474 begin
 475   StrData.Ident := Ident;
 476   StrData.Buffer := Buffer;
 477   StrData.BufSize := BufSize;
 478   StrData.nChars := 0;
 479   EnumResourceModules(EnumStringModules, @StrData);
 480   Result := StrData.nChars;
 481 end;
 482 {$ENDIF}
 483
 484 {$IFDEF _D2}
 485 function LoadStr(Ident: Integer): string;
 486 var
 487   Buffer: array[0..1023] of Char;
 488 begin
 489   SetString(Result, Buffer, LoadString(HInstance, Ident, Buffer,
 490     SizeOf(Buffer)));
 491 end;
 492 {$ELSE}
 493 function LoadStr(Ident: Integer): string;
 494 var
 495   Buffer: array[0..1023] of Char;
 496 begin
 497   SetString(Result, Buffer, FindStringResource(Ident, Buffer, SizeOf(Buffer)));
 498 end;
 499 {$ENDIF}
 500
 501 function FmtLoadStr(Ident: Integer; const Args: array of const): string;
 502 begin
 503   //FmtStr(Result, LoadStr(Ident), Args);
 504   Result := Format(LoadStr(Ident), Args);
 505 end;
 506
 507 function ExceptionErrorMessage(ExceptObject: TObject; ExceptAddr: Pointer;
 508   Buffer: PChar; Size: Integer): Integer;
 509 var
 510   MsgPtr: PChar;
 511   //MsgEnd: PChar;
 512   //MsgLen: Integer;
 513   ModuleName: array[0..MAX_PATH] of Char;
 514   //Temp: array[0..MAX_PATH] of Char;
 515   Fmt: array[0..255] of Char;
 516   Info: TMemoryBasicInformation;
 517   ConvertedAddress: Pointer;
 518 begin
 519   VirtualQuery(ExceptAddr, Info, sizeof(Info));
 520   if (Info.State <> MEM_COMMIT) or
 521     (GetModuleFilename( THandle(Info.AllocationBase), {Temp} ModuleName,
 522                         SizeOf({Temp} ModuleName)) = 0) then
 523   begin
 524     GetModuleFileName(HInstance, {Temp} ModuleName, SizeOf({Temp} ModuleName));
 525     ConvertedAddress := ConvertAddr(ExceptAddr);
 526   end
 527   else
 528     Integer(ConvertedAddress) := Integer(ExceptAddr) - Integer(Info.AllocationBase);
 529   //StrLCopy(ModuleName, AnsiStrRScan(Temp, '\') + 1, SizeOf(ModuleName) - 1);
 530   {-} // Why to extract unit name from a path? Isn't it well to show complete path
 531       // and to economy code for the extraction.
 532   MsgPtr := '';
 533   //MsgEnd := '';
 534   if ExceptObject is Exception then
 535   begin
 536     MsgPtr := PChar(Exception(ExceptObject).Message);
 537     //MsgLen := StrLen(MsgPtr);
 538     //if (MsgLen <> 0) and (MsgPtr[MsgLen - 1] <> '.') then MsgEnd := '.';
 539     {-} // Isn't it too beautiful - devote ~40 bytes of code just to decide,
 540         // add or not a point at the end of the message.
 541   end;
 542   {$IFDEF _D2orD3}
 543   StrCopy( Fmt, SException );
 544   {$ELSE}
 545   LoadString(FindResourceHInstance(HInstance),
 546     PResStringRec(@SException).Identifier, Fmt, SizeOf(Fmt));
 547   {$ENDIF}
 548   //MsgOK( ModuleName );
 549   StrCopy( Buffer, PChar( Format( Fmt, [ ExceptObject.ClassName,
 550            ModuleName, ConvertedAddress, MsgPtr, '' {MsgEnd}]) ) );
 551   Result := StrLen(Buffer);
 552 end;
 553
 554 { Display exception message box }
 555
 556 procedure ShowException(ExceptObject: TObject; ExceptAddr: Pointer);
 557 var
 558   //Title: array[0..63] of Char;
 559   Buffer: array[0..1023] of Char;
 560 begin
 561   ExceptionErrorMessage(ExceptObject, ExceptAddr, Buffer, SizeOf(Buffer));
 562   {if IsConsole then
 563     WriteLn(Buffer)
 564   else}
 565   begin
 566     {LoadString(FindResourceHInstance(HInstance), PResStringRec(@SExceptTitle).Identifier,
 567       Title, SizeOf(Title));}
 568     MessageBox(0, Buffer, {Title} nil, MB_OK or MB_ICONSTOP or MB_TASKMODAL);
 569   end;
 570 end;
 571
 572 { Raise abort exception }
 573
 574 procedure Abort;
 575
 576   function ReturnAddr: Pointer;
 577   asm
 578 //          MOV     EAX,[ESP + 4] !!! codegen dependant
 579           MOV     EAX,[EBP - 4]
 580   end;
 581
 582 begin
 583   raise Exception.Create(e_Abort, SOperationAborted) at ReturnAddr;
 584 end;
 585
 586 { Raise out of memory exception }
 587
 588 {procedure OutOfMemoryError;
 589 begin
 590   raise OutOfMemory;
 591 end;}
 592
 593 { Exception class }
 594
 595 constructor Exception.CreateResFmt(ACode: TError; Ident: Integer;
 596   const Args: array of const);
 597 begin
 598   FMessage := Format(LoadStr(Ident), Args);
 599 end;
 600
 601 destructor Exception.Destroy;
 602 begin
 603   if Assigned( FOnDestroy ) then
 604     FOnDestroy( Self );
 605   inherited;
 606 end;
 607
 608 procedure Exception.SetData(const Value: Pointer);
 609 begin
 610   FData := Value;
 611 end;
 612
 613 constructor Exception.Create(ACode: TError; const Msg: string);
 614 begin
 615   FCode := ACode;
 616   FMessage := Msg;
 617   //FAllowFree := TRUE;
 618 end;
 619
 620 constructor Exception.CreateCustom(AError: DWORD; const Msg: String);
 621 begin
 622   FCode := e_Custom;
 623   FMessage := Msg;
 624   FErrorCode := AError;
 625 end;
 626
 627 constructor Exception.CreateCustomFmt(AError: DWORD; const Msg: String;
 628   const Args: array of const);
 629 begin
 630   FCode := e_Custom;
 631   FErrorCode := AError;
 632   FMessage := Format(Msg, Args);
 633 end;
 634
 635 constructor Exception.CreateFmt(ACode: TError; const Msg: string;
 636   const Args: array of const);
 637 begin
 638   FCode := ACode;
 639   FMessage := Format(Msg, Args);
 640 end;
 641
 642 { EHeapException class }
 643
 644 {procedure EHeapException.FreeInstance;
 645 begin
 646   if AllowFree then
 647     inherited FreeInstance;
 648 end;}
 649
 650 { Create I/O exception }
 651
 652 function CreateInOutError: Exception;
 653 type
 654   TErrorRec = record
 655     Code: Integer;
 656     Ident: string;
 657   end;
 658 const
 659   ErrorMap: array[0..5] of TErrorRec = (
 660     (Code: 2; Ident: SFileNotFound),
 661     (Code: 3; Ident: SInvalidFilename),
 662     (Code: 4; Ident: STooManyOpenFiles),
 663     (Code: 5; Ident: SAccessDenied),
 664     (Code: 100; Ident: SEndOfFile),
 665     (Code: 101; Ident: SDiskFull){,
 666     (Code: 106; Ident: SInvalidInput)} );
 667 var
 668   I: Integer;
 669   InOutRes: Integer;
 670 begin
 671   I := Low(ErrorMap);
 672   InOutRes := IOResult;  // resets IOResult to zero
 673   while (I <= High(ErrorMap)) and (ErrorMap[I].Code <> InOutRes) do Inc(I);
 674   if I <= High(ErrorMap) then
 675     Result := Exception.Create(e_InOut, ErrorMap[I].Ident)
 676   else
 677     Result := Exception.CreateFmt(e_InOut, SInOutError, [InOutRes]);
 678     //Result := Exception.Create(e_InOut, SInOutError + Int2Str( InOutRes ) );
 679   Result.ErrorCode := InOutRes;
 680 end;
 681
 682 { RTL error handler }
 683
 684 type
 685   TExceptMapRec = packed record
 686     ECode: TError;
 687     EIdent: String;
 688   end;
 689
 690 const
 691   ExceptMap: array[1..24] of TExceptMapRec = (
 692     (ECode: e_OutOfMem;       EIdent: SOutOfMemory),
 693     (ECode: e_InvalidPointer; EIdent: SInvalidPointer),
 694     (ECode: e_DivBy0;         EIdent: SDivByZero),
 695     (ECode: e_Range;          EIdent: SRangeError),
 696     (ECode: e_IntOverflow;    EIdent: SIntOverflow),
 697     (ECode: e_InvalidOp;      EIdent: SInvalidOp),
 698     (ECode: e_ZeroDivide;     EIdent: SDivByZero),
 699     (ECode: e_Overflow;       EIdent: SOverflow),
 700     (ECode: e_Underflow;      EIdent: SUnderflow),
 701     (ECode: e_InvalidCast;    EIdent: SInvalidCast),
 702     (ECode: e_AccessViolation;EIdent: SAccessViolation),
 703     (ECode: e_Privilege;      EIdent: SPrivilege),
 704     (ECode: e_CtrlC;          EIdent: SControlC),
 705              // {-} Only for console applications
 706     (ECode: e_StackOverflow;  EIdent: SStackOverflow),
 707     {$IFDEF VARIANT_USED}
 708     (ECode: e_Variant;        EIdent: SInvalidVarCast),
 709     (ECode: e_Variant;        EIdent: SInvalidVarOp),
 710     (ECode: e_Variant;        EIdent: SDispatchError),
 711     (ECode: e_Variant;        EIdent: SVarArrayCreate),
 712     (ECode: e_Variant;        EIdent: SVarNotArray),
 713     (ECode: e_Variant;        EIdent: SVarArrayBounds),
 714     {$ELSE}
 715     (ECode: e_Variant;        EIdent: SVar),
 716     (ECode: e_Variant;        EIdent: SVar),
 717     (ECode: e_Variant;        EIdent: SVar),
 718     (ECode: e_Variant;        EIdent: SVar),
 719     (ECode: e_Variant;        EIdent: SVar),
 720     (ECode: e_Variant;        EIdent: SVar),
 721     {$ENDIF}
 722     (ECode: e_Assertion;      EIdent: SAssertionFailed),
 723     (ECode: e_External;       EIdent: SExternalException),
 724     (ECode: e_IntfCast;       EIdent: SIntfCastError),
 725     (ECode: e_SafeCall;       EIdent: SSafecallException));
 726
 727 procedure ErrorHandler(ErrorCode: Integer; ErrorAddr: Pointer);
 728 var
 729   E: Exception;
 730 begin
 731   {case ErrorCode of
 732     1: E := OutOfMemory;
 733     2: E := InvalidPointer;
 734     3..24: with ExceptMap[ErrorCode] do E := EClass.Create(EIdent);
 735   else
 736     E := CreateInOutError;
 737   end;}
 738
 739   { + }
 740   if ErrorCode <= 24 then
 741     with ExceptMap[ErrorCode] do E := Exception.Create(ECode, EIdent)
 742   else E := CreateInOutError;
 743   { - }
 744
 745   raise E at ErrorAddr;
 746 end;
 747
 748 { Assertion error handler }
 749
 750 { This is complicated by the desire to make it look like the exception     }
 751 { happened in the user routine, so the debugger can give a decent stack    }
 752 { trace. To make that feasible, AssertErrorHandler calls a helper function }
 753 { to create the exception object, so that AssertErrorHandler itself does   }
 754 { not need any temps. After the exception object is created, the asm       }
 755 { routine RaiseAssertException sets up the registers just as if the user   }
 756 { code itself had raised the exception.                                    }
 757
 758 function CreateAssertException(const Message, Filename: string;
 759   LineNumber: Integer): Exception;
 760 var
 761   S: string;
 762 begin
 763   if Message <> '' then S := Message else S := SAssertionFailed;
 764   Result := Exception.CreateFmt(e_Assertion, SAssertError,
 765          [S, Filename, LineNumber]);
 766 end;
 767
 768 { This code is based on the following assumptions:                         }
 769 {  - Our direct caller (AssertErrorHandler) has an EBP frame               }
 770 {  - ErrorStack points to where the return address would be if the         }
 771 {    user program had called System.@RaiseExcept directly                  }
 772 procedure RaiseAssertException(const E: Exception; const ErrorAddr, ErrorStack: Pointer);
 773 asm
 774         MOV     ESP,ECX
 775         MOV     [ESP],EDX
 776         MOV     EBP,[EBP]
 777         JMP     System.@RaiseExcept
 778 end;
 779
 780 { If you change this procedure, make sure it does not have any local variables }
 781 { or temps that need cleanup - they won't get cleaned up due to the way        }
 782 { RaiseAssertException frame works. Also, it can not have an exception frame.  }
 783 procedure AssertErrorHandler(const Message, Filename: string;
 784   LineNumber: Integer; ErrorAddr: Pointer);
 785 var
 786   E: Exception;
 787 begin
 788    E := CreateAssertException(Message, Filename, LineNumber);
 789    RaiseAssertException(E, ErrorAddr, PChar(@ErrorAddr)+4);
 790 end;
 791
 792 { Abstract method invoke error handler }
 793
 794 procedure AbstractErrorHandler;
 795 begin
 796   raise Exception.Create(e_Abstract, SAbstractError);
 797 end;
 798
 799 {$IFDEF ASM_VERSION}
 800 function MapException(P: PExceptionRecord): Byte;
 801 asm     //cmd    //opd
 802         MOV      EAX, [EAX].TExceptionRecord.ExceptionCode
 803         SUB      EAX, $C0000000
 804         CMP      EAX, $FD
 805         JA       @@code22
 806
 807         XOR      ECX, ECX
 808         MOV      EDX, offset @@cvTable - 1
 809 @@loo:
 810         INC      EDX
 811         MOV      CL, [EDX]
 812         JECXZ    @@code22
 813         INC      EDX
 814         CMP      AL, [EDX]
 815         JNE      @@loo
 816
 817         MOV      AL, CL
 818         RET
 819
 820 @@cvTable:
 821         DB       3, $94
 822         DB       4, $8C
 823         DB       5, $95
 824         DB       6, $8F, 6, $90, 6, $92
 825         DB       7, $8E
 826         DB       8, $91
 827         DB       9, $8D, 9, $93
 828         DB       11, $05
 829         DB       12, $96
 830         DB       14, $FD
 831         DB       0
 832
 833 @@code22:
 834         MOV      AL, 22
 835 end;
 836 {$ELSE} //Pascal
 837 function MapException(P: PExceptionRecord): Byte;
 838 begin
 839   case P.ExceptionCode of
 840     STATUS_INTEGER_DIVIDE_BY_ZERO:
 841       Result := 3;
 842     STATUS_ARRAY_BOUNDS_EXCEEDED:
 843       Result := 4;
 844     STATUS_INTEGER_OVERFLOW:
 845       Result := 5;
 846     STATUS_FLOAT_INEXACT_RESULT,
 847     STATUS_FLOAT_INVALID_OPERATION,
 848     STATUS_FLOAT_STACK_CHECK:
 849       Result := 6;
 850     STATUS_FLOAT_DIVIDE_BY_ZERO:
 851       Result := 7;
 852     STATUS_FLOAT_OVERFLOW:
 853       Result := 8;
 854     STATUS_FLOAT_UNDERFLOW,
 855     STATUS_FLOAT_DENORMAL_OPERAND:
 856       Result := 9;
 857     STATUS_ACCESS_VIOLATION:
 858       Result := 11;
 859     STATUS_PRIVILEGED_INSTRUCTION:
 860       Result := 12;
 861     STATUS_CONTROL_C_EXIT:
 862       Result := 13;
 863     STATUS_STACK_OVERFLOW:
 864       Result := 14;
 865   else
 866     Result := 22; { must match System.reExternalException }
 867   end;
 868 end;
 869 {$ENDIF}
 870
 871 function GetExceptionClass(P: PExceptionRecord): ExceptClass;
 872 //var ErrorCode: Byte;
 873 begin
 874   //ErrorCode := MapException(P);
 875   Result := Exception; {ExceptMap[ErrorCode].EClass;}
 876 end;
 877
 878 function GetExceptionObject(P: PExceptionRecord): Exception;
 879 var
 880   ErrorCode: Integer;
 881
 882   function CreateAVObject: Exception;
 883   var
 884     AccessOp: string; // string ID indicating the access type READ or WRITE
 885     AccessAddress: Pointer;
 886     MemInfo: TMemoryBasicInformation;
 887     ModName: array[0..MAX_PATH] of Char;
 888   begin
 889     with P^ do
 890     begin
 891       if ExceptionInformation[0] = 0 then
 892         AccessOp := SReadAccess else
 893         AccessOp := SWriteAccess;
 894       AccessAddress := Pointer(ExceptionInformation[1]);
 895       VirtualQuery(ExceptionAddress, MemInfo, SizeOf(MemInfo));
 896       if (MemInfo.State = MEM_COMMIT) and (GetModuleFileName(THandle(MemInfo.AllocationBase),
 897         ModName, SizeOf(ModName)) <> 0) then
 898         Result := Exception.CreateFmt(e_AccessViolation, sModuleAccessViolation,
 899           [ExceptionAddress, ExtractFileName(ModName), AccessOp,
 900           AccessAddress])
 901       else Result := Exception.CreateFmt(e_AccessViolation, sAccessViolation,
 902           [ExceptionAddress, AccessOp, AccessAddress]);
 903     end;
 904   end;
 905
 906 begin
 907   ErrorCode := MapException(P);
 908   case ErrorCode of
 909     3..10, 12..21:
 910       with ExceptMap[ErrorCode] do Result := Exception.Create(ECode, EIdent);
 911     11: Result := CreateAVObject;
 912   else
 913     begin
 914       Result := Exception.CreateFmt(e_External, SExternalException, [P.ExceptionCode]);
 915       //Result.FExceptionRecord := P;
 916     end;
 917   end;
 918   Result.FExceptionRecord := P;
 919 end;
 920
 921 { RTL exception handler }
 922
 923 procedure ExceptHandler(ExceptObject: TObject; ExceptAddr: Pointer); far;
 924 begin
 925   ShowException(ExceptObject, ExceptAddr);
 926   Halt(1);
 927 end;
 928
 929 {+}
 930 function InitAssertErrorProc: Boolean;
 931 begin
 932   AssertErrorProc := @AssertErrorHandler;
 933   Result := TRUE;
 934 end;
 935 {-}
 936
 937 procedure InitExceptions;
 938 begin
 939   {OutOfMemory := EOutOfMemory.Create(SOutOfMemory);
 940   InvalidPointer := EInvalidPointer.Create(SInvalidPointer);}
 941   ErrorProc := @ErrorHandler;
 942   ExceptProc := @ExceptHandler;
 943   ExceptionClass := Exception;
 944
 945   ExceptClsProc := @GetExceptionClass;
 946
 947   ExceptObjProc := @GetExceptionObject;
 948
 949   {AssertErrorProc := @AssertErrorHandler;}
 950   {+} // Initialize Assert only when "Assertions" option is turned on in Compiler:
 951   Assert( InitAssertErrorProc, '' );
 952   {-}
 953
 954   //AbstractErrorProc := @AbstractErrorHandler;
 955   // {-} KOL does not use classes, so EAbstractError should never be raised.
 956
 957 end;
 958
 959 procedure DoneExceptions;
 960 begin
 961   {OutOfMemory.AllowFree := True;
 962   OutOfMemory.FreeInstance;
 963   OutOfMemory := nil;
 964   InvalidPointer.AllowFree := True;
 965   InvalidPointer.Free;
 966   InvalidPointer := nil;}
 967   ErrorProc := nil;
 968   ExceptProc := nil;
 969   ExceptionClass := nil;
 970   //ExceptClsProc := nil; --see InitExceptions
 971   ExceptObjProc := nil;
 972   AssertErrorProc := nil;
 973 end;
 974
 975 { RaiseLastWin32Error }
 976
 977 procedure RaiseLastWin32Error;
 978 var
 979   LastError: DWORD;
 980   Error: Exception;
 981 begin
 982   LastError := GetLastError;
 983   if LastError <> ERROR_SUCCESS then
 984     Error := Exception.CreateFmt(e_Win32, SWin32Error, [LastError,
 985       SysErrorMessage(LastError)])
 986   else
 987     Error := Exception.Create(e_Win32, SUnkWin32Error );
 988   Error.ErrorCode := LastError;
 989   raise Error;
 990 end;
 991
 992 { Win32Check }
 993
 994 function Win32Check(RetVal: BOOL): BOOL;
 995 begin
 996   if not RetVal then RaiseLastWin32Error;
 997   Result := RetVal;
 998 end;
 999
1000 type
1001   PTerminateProcInfo = ^TTerminateProcInfo;
1002   TTerminateProcInfo = record
1003     Next: PTerminateProcInfo;
1004     Proc: TTerminateProc;
1005   end;
1006
1007 var
1008   TerminateProcList: PTerminateProcInfo = nil;
1009
1010 procedure AddTerminateProc(TermProc: TTerminateProc);
1011 var
1012   P: PTerminateProcInfo;
1013 begin
1014   New(P);
1015   P^.Next := TerminateProcList;
1016   P^.Proc := TermProc;
1017   TerminateProcList := P;
1018 end;
1019
1020 function CallTerminateProcs: Boolean;
1021 var
1022   PI: PTerminateProcInfo;
1023 begin
1024   Result := True;
1025   PI := TerminateProcList;
1026   while Result and (PI <> nil) do
1027   begin
1028     Result := PI^.Proc;
1029     PI := PI^.Next;
1030   end;
1031 end;
1032
1033 procedure FreeTerminateProcs;
1034 var
1035   PI: PTerminateProcInfo;
1036 begin
1037   while TerminateProcList <> nil do
1038   begin
1039     PI := TerminateProcList;
1040     TerminateProcList := PI^.Next;
1041     Dispose(PI);
1042   end;
1043 end;
1044
1045 { --- }
1046
1047 function AL1(const P): LongWord;
1048 asm
1049         MOV     EDX,DWORD PTR [P]
1050         XOR     EDX,DWORD PTR [P+4]
1051         XOR     EDX,DWORD PTR [P+8]
1052         XOR     EDX,DWORD PTR [P+12]
1053         MOV     EAX,EDX
1054 end;
1055
1056 function AL2(const P): LongWord;
1057 asm
1058         MOV     EDX,DWORD PTR [P]
1059         ROR     EDX,5
1060         XOR     EDX,DWORD PTR [P+4]
1061         ROR     EDX,5
1062         XOR     EDX,DWORD PTR [P+8]
1063         ROR     EDX,5
1064         XOR     EDX,DWORD PTR [P+12]
1065         MOV     EAX,EDX
1066 end;
1067
1068 const
1069   AL1s: array[0..2] of LongWord = ($FFFFFFF0, $FFFFEBF0, 0);
1070   AL2s: array[0..2] of LongWord = ($42C3ECEF, $20F7AEB6, $D1C2F74E);
1071
1072 procedure ALV;
1073 begin
1074   raise Exception.Create(e_License, SNL);
1075 end;
1076
1077 {$IFNDEF _D2}
1078 function ALR: Pointer;
1079 var
1080   LibModule: PLibModule;
1081 begin
1082   if MainInstance <> 0 then
1083     Result := Pointer(LoadResource(MainInstance, FindResource(MainInstance, 'DVCLAL',
1084       RT_RCDATA)))
1085   else
1086   begin
1087     Result := nil;
1088     LibModule := LibModuleList;
1089     while LibModule <> nil do
1090     begin
1091       with LibModule^ do
1092       begin
1093         Result := Pointer(LoadResource(Instance, FindResource(Instance, 'DVCLAL',
1094           RT_RCDATA)));
1095         if Result <> nil then Break;
1096       end;
1097       LibModule := LibModule.Next;
1098     end;
1099   end;
1100   if Result = nil then ALV;
1101 end;
1102
1103 function GDAL: LongWord;
1104 type
1105   TDVCLAL = array[0..3] of LongWord;
1106   PDVCLAL = ^TDVCLAL;
1107 var
1108   P: Pointer;
1109   A1, A2: LongWord;
1110   PAL1s, PAL2s: PDVCLAL;
1111   ALOK: Boolean;
1112 begin
1113   P := ALR;
1114   A1 := AL1(P^);
1115   A2 := AL2(P^);
1116   Result := A1;
1117   PAL1s := @AL1s;
1118   PAL2s := @AL2s;
1119   ALOK := ((A1 = PAL1s[0]) and (A2 = PAL2s[0])) or
1120           ((A1 = PAL1s[1]) and (A2 = PAL2s[1])) or
1121           ((A1 = PAL1s[2]) and (A2 = PAL2s[2]));
1122   FreeResource(Integer(P));
1123   if not ALOK then ALV;
1124 end;
1125
1126 procedure RCS;
1127 var
1128   P: Pointer;
1129   ALOK: Boolean;
1130 begin
1131   P := ALR;
1132   ALOK := (AL1(P^) = AL1s[2]) and (AL2(P^) = AL2s[2]);
1133   FreeResource(Integer(P));
1134   if not ALOK then ALV;
1135 end;
1136
1137 procedure RPR;
1138 var
1139   AL: LongWord;
1140 begin
1141   AL := GDAL;
1142   if (AL <> AL1s[1]) and (AL <> AL1s[2]) then ALV;
1143 end;
1144 {$ENDIF}
1145
1146 {$IFNDEF _D2orD3}
1147 function SafeLoadLibrary(const Filename: string; ErrorMode: UINT): HMODULE;
1148 var
1149   OldMode: UINT;
1150   FPUControlWord: Word;
1151 begin
1152   OldMode := SetErrorMode(ErrorMode);
1153   try
1154     asm
1155       FNSTCW  FPUControlWord
1156     end;
1157     try
1158       Result := LoadLibrary(PChar(Filename));
1159     finally
1160       asm
1161         FNCLEX
1162         FLDCW FPUControlWord
1163       end;
1164     end;
1165   finally
1166     SetErrorMode(OldMode);
1167   end;
1168 end;
1169 {$ENDIF}
1170
1171 {procedure Exception.FreeInstance;
1172 begin
1173   if FAllowFree then
1174     inherited;
1175 end;}
1176
1177
1178
1179 initialization
1180   InitExceptions;
1181
1182 finalization
1183   FreeTerminateProcs;
1184   DoneExceptions;
1185
1186 end.
1187