home *** CD-ROM | disk | FTP | other *** search
/ Piper's Pit BBS/FTP: ibm 0010 - 0019 / ibm0010-0019 / ibm0010.tar / ibm0010 / CLIPB52.ZIP / SCHWARTZ.ZIP / MYERR.PRG < prev   
Encoding:
Text File  |  1990-06-06  |  6.3 KB  |  204 lines
  1. /*********************************************************************
  2. *
  3. * Name:        MYERR.prg
  4. * Description:  Demo replacement for Nantucket-supplied ERRORBLOCK()
  5. * Author:    Philip H. Schwartz
  6. * Audience:    Nantucket DEVCON '90
  7. * Written:      June 5, 1990
  8. * Compiler:    Clipper 5.0 V7.7 BETA
  9. * Options:     /N
  10. * Linker:       RTLink Version 1.3 (Clipper)
  11. * Library:    clipper, extend
  12. * Inc/object:   as needed
  13. * Headers:    STD.ch, ERROR.ch
  14. * Copyright:    (c) 1990 Philip H. Schwartz
  15. * Rights:    All Commercial & Publishing Rights Reserved
  16. *
  17. *********************************************************************/
  18.  
  19. #include "error.ch"
  20. #include "inkey.ch"
  21.  
  22. /* Message pseudo functions */
  23. #define OUT(str)        ErrMsg=ErrMsg+(str)
  24. #define OUTNL(str)              ErrMsg="";ErrMsg=ErrMsg+(str)
  25.  
  26. /* Definitions for MEMORY() function */
  27. #define MEM_TOTAL        0
  28. #define MEM_BLOCK        1
  29. #define MEM_RUN            2            
  30.  
  31. ***
  32. *    MyError()
  33. *
  34. FUNCTION MyError(e)
  35. LOCAL i,ErrMsg,LogId,lRetry,lSubstitute
  36.  
  37. /* Check for presence of Errorlog.dbf and Trace.dbf and
  38.    build them if necessary                                */
  39. BuildFiles()
  40.  
  41. /* Display instance variables in the current error object */
  42. IF "OBJECTS"$UPPER(GETENV("DEBUG"))
  43.   ShowObject(e)
  44. ENDIF
  45.  
  46. /* Check to see if RETRY is requested */
  47. IF ("RETRY"$UPPER(GETENV("DEBUG")) .AND. e:canRetry)
  48.   lRetry=.f.
  49.   @ 0,70 SAY "Retry?" GET lRetry PICTURE 'L'
  50.   READ
  51.   RETURN(lRetry)
  52. ENDIF
  53.  
  54. /* Check to see if SUBSTITUTE is requested */
  55. IF ("SUBSTITUTE"$UPPER(GETENV("DEBUG")) .AND. e:canSubstitute)
  56.   lSubstitute=.f.
  57.   @ 0,65 SAY "Substitute?" GET lSubstitute PICTURE 'L'
  58.   READ
  59.   RETURN("*Substituted*")        // example substitution
  60. ENDIF
  61.  
  62. CLS
  63. /* Ignore open error and NETERR() with canDefault */
  64. IF (e:genCode == EG_OPEN .AND. NetErr() .AND. e:canDefault)
  65.   RETURN (.f.)    /* ignore */
  66. END
  67.  
  68. /* Start building an error message */
  69. OUTNL( "Error" )
  70.  
  71. /* Check for presence of subsystem */
  72. IF (!EMPTY(e:subsystem()))
  73.   OUT(" "+e:subsystem()+"["+LTRIM(STR(e:subCode()))+"]")
  74. END
  75.  
  76. /* Check for presence of description */
  77. IF (!EMPTY(e:description()))
  78.   OUT("  "+e:description())
  79. END
  80.  
  81. /* Check for presence of operation */
  82. IF (!EMPTY(e:operation()))
  83.   OUT(": "+e:operation())
  84. END
  85.  
  86. /* Check for presence of file name */
  87. IF (!EMPTY(e:filename()))
  88.   OUT(": "+e:filename())
  89. END
  90.  
  91. /* Print the message to the STD output device */
  92. __OUTSTD( Chr(13) + Chr(10) + ErrMsg)
  93.  
  94. /* Check to see if log to error DBF is requested.  The
  95.    Log id number is constructed from the date and time.  */
  96. IF "LOG"$UPPER(GETENV("DEBUG"))
  97.   LogId=VAL(DTOS(DATE())+STRTRAN(TIME(),":",""))
  98.   ErrLog(LogId,ErrMsg)
  99.   USE trace NEW
  100. ENDIF
  101.  
  102. /* Loop through Call Stack and print calling history to
  103.    SCREEN and optionally generate an entry in the TRACE file. */ 
  104. i:=2
  105. WHILE(.t.)
  106.   OUTNL( "Called from " + TRIM(ProcName(i)) + ;
  107.    "(" + ALLTRIM(STR(ProcLine(i))) + ")  " )
  108.  
  109.   __OUTSTD( Chr(13) + Chr(10) + ErrMsg)
  110.   IF "LOG"$UPPER(GETENV("DEBUG"))
  111.     APPEND BLANK
  112.     REPLACE errnum WITH LogId,procname WITH PROCNAME(i),;
  113.      procline WITH PROCLINE(i)
  114.   ENDIF
  115.   i++
  116.   IF ( PROCNAME(i) == "" )        // check for end of the stack    
  117.     IF "BREAK"$UPPER(GETENV("DEBUG"))    // check for BREAK request
  118.       BREAK e                // yes, pass error object on
  119.     ELSE
  120.       ERRORLEVEL(1)            // otherwise, quit
  121.       QUIT
  122.     ENDIF
  123.   END
  124. END
  125. CLOSE DATABASES
  126. RETURN (.f.)
  127.  
  128. /* This function opens the ERRORLOG DBF and creates an entry that
  129.    describes the nature of the current error condition.  We will
  130.    use the DUMPERRS.exe program to query this file later.          */
  131. STATIC FUNCTION ErrLog
  132. PARAMETER nId,cMsg
  133. USE errorlog NEW
  134. APPEND BLANK
  135. REPLACE errnum WITH nId,procname WITH PROCNAME(3),;
  136.  procline WITH PROCLINE(3),;
  137.  version WITH IIF(VALTYPE(sys_vers)='N',sys_vers,0),;
  138.  exelevel WITH IIF(VALTYPE(sys_exe)='N',sys_exe,0),;
  139.  termdate WITH DATE(),termtime WITH TIME(),;
  140.  text WITH cMsg,memtot WITH MEMORY(MEM_TOTAL),memblock WITH MEMORY(MEM_BLOCK),;
  141.  memrun WITH MEMORY(MEM_RUN)
  142. USE
  143.  
  144. /* If requested and if there is at least 60K, we SAVE all variables
  145.    supported by .MEM files to ERRORLOG.mem.                             */
  146. IF "MEM"$UPPER(GETENV("DEBUG")) .AND. DISKSPACE()>60000
  147.   SAVE ALL LIKE *.* TO errorlog
  148. ENDIF
  149. COMMIT                    // DOS 3.3 above, flush buffers
  150. TONE(500,3)                // Play distinctive
  151. TONE(750,5)                //   three notes to let user
  152. TONE(2000,12)                //   know our handler has been invoked
  153. RETURN("")
  154.  
  155. /* This function checks for the presence of the ERRORLOG.dbf and
  156.    TRACE.dbf files and creates them if they are missing.  The ERRORLOG.dbf
  157.    contains descriptive information about the error condition and the
  158.    TRACE.dbf contains the Call Stack data.                               */
  159. STATIC FUNCTION BuildFiles
  160. LOCAL aDbf
  161. IF !FILE("Errorlog.dbf")
  162.   aDbf:={{"Errnum","N",14,0},;
  163.          {"Version","N",5,2},;
  164.          {"Exelevel","N",7,3},;
  165.          {"Termdate","D",0,0},;
  166.          {"Termtime","C",8,0},;
  167.          {"Text","C",80,0},;
  168.          {"Memtot","N",7,0},;
  169.          {"Memblock","N",7,0},;
  170.          {"Memrun","N",7,0},;
  171.          {"Procname","C",10,0},;
  172.          {"Procline","N",8,0}}
  173.   DBCREATE("Errorlog",aDbf)
  174. ENDIF
  175. IF !FILE("Trace.dbf")
  176.   aDbf:={{"Errnum","N",14,0},;
  177.          {"Procname","C",10,0},;
  178.          {"Procline","N",8,0}}
  179.   DBCREATE("Trace",aDbf)
  180. ENDIF
  181. RETURN NIL
  182.  
  183. /* This function displays the variables associated with the
  184.    current Error Object.                                       */
  185. STATIC FUNCTION ShowObject(e)
  186. CLS
  187. ? "Current Error Object Variables:"
  188. ? REPLICATE("-",80)
  189. ? "e:canDefault is:           "+IIF(e:canDefault,"TRUE","FALSE" )
  190. ? "e:canRetry is:             "+IIF(e:canRetry ,"TRUE","FALSE")
  191. ? "e:canSubstitute is:        "+IIF(e:cansubstitute,"TRUE","FALSE" )
  192. ? "e:cargo() is:              ",e:cargo()
  193. ? "e:description() is:        "+e:description()
  194. ? "e:filename() is:           "+e:filename()
  195. ? "e:genCode() is:            "+LTRIM(STR(e:genCode()))
  196. ? "e:operation() is:          "+e:operation()
  197. ? "e:osCode() is:             "+LTRIM(STR(e:osCode()))
  198. ? "e:subCode() is:            "+LTRIM(STR(e:subCode()))
  199. ? "e:subsystem() is:          "+e:subsystem()
  200. ? "e:tries() is:              "+LTRIM(STR(e:tries()))
  201. INKEY(0)
  202. RETURN NIL
  203. /*EOF*/
  204.