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