home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 19 / CD_ASCQ_19_010295.iso / dos / prg / pas / pmd110 / bberror.pas < prev    next >
Pascal/Delphi Source File  |  1994-11-13  |  7KB  |  109 lines
  1. (* This file was mangled by Mangler 1.35 (c) Copyright 1993-1994 by Berend de Boer *)
  2. { Created : 01-06-'90
  3.  
  4. Last changes :
  5. 91-07-10  Adapted for use in TP6.0 and Turbo Vision
  6. 92-07-02  Added log file ferr where an application can write error codes to
  7. 92-12-04  Added code to clear IOResult so an errormessage can be written to
  8.           the log file
  9. 93-01-18  Installed a simple Heap function to return 1 when a request for
  10.           memory could not be fulfilled
  11. 93-01-28  Deleted statements which disposed an Application if an error was
  12.           detected
  13. 93-05-05  Added a dump stack procedure
  14. 93-12-01  Added a hook for the Post Mortem Debugger, simple change the
  15.           procedure variable HandleRunTimeError
  16. 94-03-17  Renamed InstallExitHandler to InitBBError
  17. 94-05-16  Adapted to Windows target
  18. 94-10-24  Improved stack walking with better near call detection
  19.  
  20.  
  21. Expects that an application object was running
  22. }
  23.  
  24.  
  25.  
  26. {$IFDEF MSDOS}
  27. {$O+,F+,D-}
  28. {$ENDIF}
  29.  
  30. {$I-,V-,Q-,R-,S-}
  31. unit BBError;
  32.  
  33. interface
  34.  
  35. uses
  36.   Objects,
  37.   {$IFDEF Windows}
  38.   BBFile
  39.   {$ELSE}
  40.   Dos
  41.   {$ENDIF};
  42.  
  43.  
  44. const
  45.   FatalErrorText:string[128] = 'Fatal error. Errorcode: ';
  46.  
  47. type
  48.   HandleRunTimeErrorProcedureType = procedure(StackFrame : word);
  49.   DumpStackProcedureType = procedure(Addr : pointer; StackFrame : word);
  50.  
  51. var
  52.   ferr : text;
  53.   HandleRunTimeError : HandleRunTimeErrorProcedureType;
  54.   DumpStack : DumpStackProcedureType;
  55.  
  56.  
  57. function  GetLogicalAddr(Addr : pointer) : pointer;
  58. function  IsValidPtr(Addr : pointer) : Boolean;
  59. procedure LogError(const s : string);
  60. function  InitBBError(const AFileName : PathStr; bAppend : Boolean) : Boolean;
  61.  
  62.  
  63.  
  64.  
  65.  IMPLEMENTATION USES {$IFNDEF MsDos}WINAPI , {$ENDIF}{$IFNDEF Windows}BBFILE , {$ENDIF}BBGUI , BBUTIL ;
  66. FUNCTION GETLOGICALADDR (ADDR:POINTER):POINTER ;ASSEMBLER;ASM {} {$IFNDEF MsDos} {} MOV DX , WORD PTR ADDR+ 2 {}
  67. CMP DX , 0 {} JE @@end {} VERR DX {} JE @@selok {} XOR DX , DX {} JMP @@end {} @@selok : {} MOV ES , DX {}
  68. MOV DX , WORD PTR ES : [ 0 ] {} @@end : {} MOV AX , WORD PTR ADDR{} {$ENDIF} {} {$IFDEF MsDos} {}
  69. MOV CX , WORD PTR ADDR{} MOV BX , WORD PTR ADDR+ 2 {} MOV AX , OVRLOADLIST{} @@0 : {} OR AX , AX {} JE @@3 {}
  70. MOV ES , AX {} MOV AX , ES : WORD PTR 16 {} OR AX , AX {} JE @@1 {} SUB AX , BX {} JA @@1 {} NEG AX {} CMP AX , 1000h {}
  71. JAE @@1 {} MOV DX , 16 {} MUL DX {} ADD AX , CX {} JC @@1 {} CMP AX , ES : WORD PTR 8 {} JB @@2 {} @@1 : {}
  72. MOV AX , ES : WORD PTR 20 {} JMP @@0 {} @@2 : {} MOV CX , AX {} MOV BX , ES {} @@3 : {} SUB BX , PREFIXSEG{}
  73. SUB BX , 10h {} MOV AX , CX {} MOV DX , BX {} {$ENDIF} {} END;FUNCTION ISVALIDPTR (ADDR:POINTER):BOOLEAN ;ASSEMBLER;
  74. ASM {} {$IFNDEF MsDos} {} XOR AX , AX {} MOV DX , WORD PTR ADDR+ 2 {} CMP DX , 0 {} JE @@exit {} VERR DX {} JNE @@exit {}
  75. INC AX {} @@exit : {} {$ELSE} {} MOV AX , 1 {} {$ENDIF} {} END;PROCEDURE O100I0IOIOl (OOlIl0OOIIOO:POINTER;
  76. O100llIl00IOl:WORD);FAR;VAR O101O01III1II:WORD;O100Ol00I:POINTER;OI11OO1I0:WORD;PROCEDURE O1011O1IO1O10
  77. (OOlIl0OOIIOO:POINTER);BEGIN WITH PTRREC(OOlIl0OOIIOO) DO WRITELN (FERR , '  ', HEXSTR (SEG ), ':', HEXSTR (OFS ));END ;
  78. FUNCTION OOIO11111111 :BOOLEAN ;VAR OOIl0I00O1O0:POINTER;BEGIN OOIO11111111 := FALSE ;IF O100Ol00I =NIL THEN EXIT ;
  79. PTRREC (OOIl0I00O1O0 ). OFS := PTRREC (OOlIl0OOIIOO ). OFS ;{$IFDEF MsDos}PTRREC (OOIl0I00O1O0 ). SEG := OI11OO1I0 ;
  80. {$ELSE}IF GETSELECTORLIMIT (OI11OO1I0 )<= PTRREC (OOIl0I00O1O0 ). OFS THEN EXIT ;PTRREC (OOIl0I00O1O0 ). SEG :=
  81. ALLOCSELECTOR (OI11OO1I0 );IF PTRREC (OOIl0I00O1O0 ). SEG =0 THEN EXIT ;
  82. {$ENDIF}WITH PTRREC(OOIl0I00O1O0) DO OOIO11111111 := (MEMW [ SSEG :O100llIl00IOl + 4 ] =O101O01III1II )OR ((OFS >= 5 )AND
  83. (MEM [ SEG :OFS - 3 ] =$E8 )AND (MEM [ SEG :OFS - 5 ] <> $9A ));{$IFNDEF MsDos}FREESELECTOR (PTRREC (OOIl0I00O1O0 ). SEG
  84. );{$ENDIF}END ;BEGIN IF NOT ISFILEOPEN (FERR )THEN EXIT ;LOGERROR ('**Stack dump. Callers shown only**');IF ODD
  85. (O100llIl00IOl )THEN DEC (O100llIl00IOl );O101O01III1II := MEMW [ SSEG :O100llIl00IOl ] ;IF ODD (O101O01III1II )THEN DEC
  86. (O101O01III1II );O100Ol00I := OOlIl0OOIIOO ;OI11OO1I0 := PTRREC (O100Ol00I ). SEG ;WHILE (O101O01III1II > O100llIl00IOl
  87. )AND (MEMW [ SSEG :O100llIl00IOl ] <> 0 ) DO BEGIN PTRREC (OOlIl0OOIIOO ). OFS := MEMW [ SSEG :O100llIl00IOl + 2 ] ;IF
  88. OOIO11111111 THEN PTRREC (OOlIl0OOIIOO ). SEG := PTRREC (O100Ol00I ). SEG ELSE BEGIN OI11OO1I0 := MEMW [ SSEG
  89. :O100llIl00IOl + 4 ] ;PTRREC (OOlIl0OOIIOO ). SEG := MEMW [ SSEG :O100llIl00IOl + 4 ] ;OOlIl0OOIIOO := GETLOGICALADDR
  90. (OOlIl0OOIIOO );IF OOlIl0OOIIOO =NIL THEN BREAK ;{$IFNDEF MsDos}IF PTRREC (OOlIl0OOIIOO ). SEG =0 THEN PTRREC
  91. (OOlIl0OOIIOO ). SEG := PTRREC (O100Ol00I ). SEG ;{$ENDIF}END ;O100llIl00IOl := O101O01III1II ;O1011O1IO1O10
  92. (OOlIl0OOIIOO );O101O01III1II := MEMW [ SSEG :O100llIl00IOl ] ;IF ODD (O101O01III1II )THEN DEC (O101O01III1II );
  93. O100Ol00I := OOlIl0OOIIOO ;END ;FLUSH (FERR );END ;PROCEDURE LOGERROR (CONST S:STRING );VAR OIOO:INTEGER;BEGIN IF
  94. ISFILEOPEN (FERR )THEN BEGIN OIOO := IORESULT ;WRITELN (FERR , GETDATESTR , ' ', GETTIMESTR , '  ', S );FLUSH (FERR );
  95. END ;END ;PROCEDURE O10O0I0llIOl0 (O100llIl00IOl:WORD);FAR;BEGIN WRITE (FERR , GETDATESTR , '  ', GETTIMESTR , '  ');
  96. WRITE (FERR , 'Errorcode = ', EXITCODE , '  ');WRITELN (FERR , 'Erroraddr = ', HEXSTR (PTRREC (ERRORADDR ). SEG ), ':',
  97. HEXSTR (PTRREC (ERRORADDR ). OFS ));WRITELN (FERR , 'MaxAvail = ', MAXAVAIL );WRITELN (FERR , 'MemAvail = ', MEMAVAIL );
  98. DUMPSTACK (ERRORADDR , O100llIl00IOl );CLOSE (FERR );APPEND (FERR );INFOBOX (FATALERRORTEXT + STRW (EXITCODE ), 0 );
  99. END ;VAR O1lO11Il00lI:POINTER;PROCEDURE OIO0OO1100O ;FAR;VAR OIOO:WORD;OIO1OO11I1:WORD;BEGIN ASM {} MOV AX , BP {}
  100. SHR AX , 1 {} SHL AX , 1 {} MOV OIO1OO11I1, AX {} END;EXITPROC := O1lO11Il00lI ;OIOO := IORESULT ;IF (EXITCODE =0 )OR
  101. (ERRORADDR =NIL )THEN BEGIN LOGERROR ('MemAvail when program ended: '+ STRL (MEMAVAIL ));WRITELN (FERR ,
  102. 'Program ended on ', GETDATESTR , ' at ', GETTIMESTR );CLOSE (FERR );EXIT ;END ;HANDLERUNTIMEERROR (OIO1OO11I1 );CLOSE
  103. (FERR );END ;{$IFNDEF MsDos}FUNCTION O1011I1OlOIO1 (OI1OIIIl0lO1:WORD):INTEGER ;FAR;BEGIN O1011I1OlOIO1 := 1 ;END ;
  104. {$ENDIF}FUNCTION INITBBERROR (CONST AFILENAME:PATHSTR;BAPPEND:BOOLEAN):BOOLEAN ;BEGIN INITBBERROR := FALSE ;O1lO11Il00lI
  105. := EXITPROC ;EXITPROC := @ OIO0OO1100O ;DUMPSTACK := O100I0IOIOl ;HANDLERUNTIMEERROR := O10O0I0llIOl0 ;ASSIGN (FERR ,
  106. AFILENAME );IF (NOT BAPPEND )OR (NOT FILEEXIST (AFILENAME ))THEN REWRITE (FERR )ELSE APPEND (FERR );IF IOERROR (AFILENAME
  107. , 0 )THEN EXIT ;WRITELN (FERR );WRITELN (FERR , '** Program started on ', GETDATESTR , ' at ', GETTIMESTR , ' **');
  108. {$IFNDEF MsDos}HEAPERROR := @ O1011I1OlOIO1 ;{$ENDIF}INITBBERROR := IORESULT =0 ;END ;END .
  109.