Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

Register Log in
  • Congratulations Mike Lewis on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

I need a user friendly error routine

FoxPro Error Codes

I need a user friendly error routine

by  DSummZZZ  Posted    (Edited  )
In response to a request for my error routine, I decided I would just post it as an FAQ so anyone else who wanted to use it could. I have tested this faq in Foxpro 2.5 for Windows and DOS, and didn't run across any problems. Be sure and let me know if you run into any though so I can fix them here.

What is does:
1- The error routine is first placed in memory as a procedure file using:

SET PROCEDURE TO err

Of course, the code can be pasted into another procedure file if you prefer.

2- The default error handler is changed to the user defined error handler by issuing the statement:
Code: 
ON ERROR DO errhand WITH ;
   ERROR(),    ;
   MESSAGE(),  ;
   MESSAGE(1), ;
   LINENO()

3- When a programmatic error occurs, the routine writes four files, 12345678.*, where 12345678 is a random generated file name, eight digits set by SYS(3) plus extensions of .ERR, .ERS, .ERM and .ERC. In other words, for each occurrence of an error, four files will be created with the same first eight numbers as the file name, but will contain the four different extensions.

For example:
12345678.ERR - includes user name, error name, error number, call stack, and so on.

12345678.ERM - contains a memory dump.

12345678.ERS - contains a 'LIST STATUS' dump, showing all open tables, selected work area etc.

12345678.ERC - screen dump prior to the error window being displayed.

To view the first three files, just open them up using MODIFY FILE. The fourth will be gibberish, but contains a memory variable named 'mscrndump' which consists of the screen dump. To view the screen dump, just perform these steps:

RESTORE FROM 12345678.ERC
RESTORE SCREEN FROM mscrndump

4- An error window is displayed which allows the user to select 'Retry' or 'Cancel'. I allow a retry becuase it gives the user a chance to retry on simple errors, without having to exit the program and start all over. They usually don't care what the exact error is, so I don't display it. They can retry a time or two and if it doesn't 'magically' fix itself, they cancel. Most errors I have seen have been something minor which neither cause any problems nor require my assistance. Of course, you can be your own judge, and if you think it's necessary, implement a retry counter to force the use out of the application, or just eliminate the retry button all together.


So here is the code:

Code: 
*.............  ERR.PRG ................*
*!*****************************************************************************
*!
*!      Procedure: errhand
*!
*!*****************************************************************************
PROCEDURE errhand
PARAMETER merror, MESS, mess1, mlineno


IF merror = 43 .OR. merror = 1405
   DO nomem
ENDIF ( merror = 43 .OR. merror = 1405 )

IF TYPE("s_username") = "U" 
   STORE GETENV("USERNAME") TO s_username
ENDIF

STORE DTOC(DATE()) TO datestr
STORE TIME() TO timestr

IF TYPE("cfgdatapath" ) # "U"
   STORE ALLTRIM(cfgdatapath) + SYS(3) TO errfile
ELSE
   STORE SYS(3) TO errfile
ENDIF ( TYPE("cfgdatapath" ) # "U" )

*... This section saves the screen to a screen file 
STORE errfile + '.erc' TO sdump
SAVE SCREEN TO mScrnDump
SAVE ALL LIKE mScrnDump TO (sdump)

STORE errfile + '.err' TO prgdump
x=FCREATE(prgdump)
IF x < 0
   DO caution WITH ;
      "FATAL ERROR | Retval: "+ ALLTRIM(STR(x)) ,;
      "Unable to open error log file: {"+ prgdump + "}"
   set sysmenu to default
   ON ERROR
   CANCEL
ELSE
   =FPUTS(x, '------' + datestr + ' at ' + timestr + " File: " + errfile + '------')
   =FPUTS(x, 'Username...................: ' + m.s_username)
   =FPUTS(x, 'Error number...............: ' + LTRIM(STR(merror)))
   =FPUTS(x, 'Error message..............: ' + MESS)
   =FPUTS(x, 'Error message parameter....: ' + SYS(2018))
   =FPUTS(x, 'Line of code with error....: ' + mess1)
   =FPUTS(x, 'Line number of error.......: ' + LTRIM(STR(mlineno)))

   STORE 1 TO prgcountr
   STORE 'DAVE' TO theprg
   DO WHILE ALLTRIM(theprg) # '
      theprg = PROGRAM(prgcountr)
      =FPUTS(x, 'Program level ' + LTRIM(STR(prgcountr)) + ')...........: ' + theprg)
      prgcountr = prgcountr + 1
   ENDDO ( ALLTRIM(theprg) # ' )

   =FPUTS(x, 'User allocated memory......: ' + SYS(1016))
   =FPUTS(x, 'Selected DBF...............: ' + DBF())
   =FPUTS(x, 'Current lock status........: ' + SYS(2011))
   =FPUTS(x, 'Controlling index number...: ' + SYS(21))
   =FPUTS(x, 'Controlling index name.....: ' + SYS(22))
   =FPUTS(x, '-------------------------------------------------------------------')

   =FCLOSE(x)
ENDIF ( x < 0 )

LIST MEMO   TO errfile+'.erm' NOCONSOLE
LIST STATUS TO errfile+'.ers' NOCONSOLE

DEFINE WINDOW err;
   FROM  0.000, 0.000  ;
   TO 12, 80 ;
   TITLE "*** Internal Error ***" ;
   FONT "FoxFont", 8 ;
   FLOAT ;
   CLOSE ;
   nominimize ;
   SYSTEM ;
   COLOR RGB(,,,255,0,0)
MOVE WINDOW err CENTER

ACTIVATE WINDOW err TOP

@   1,  1 SAY "A system error has occurred." ;
    FONT "System", 9 COLOR RGB(255,255,0,255,0,0)
@ 2.5,  1 SAY "Please inform programming staff." ;
    FONT "System", 9 COLOR RGB(255,255,0,255,0,0)
@   4,  1 SAY "You may try 'Retry', but if errors" ;
    FONT "System", 9 COLOR RGB(255,255,0,255,0,0)
@ 5.5,  1 SAY "persist, press 'Cancel'." ;
    FONT "System", 9 COLOR RGB(255,255,0,255,0,0)
STORE ' TO booboo

@ 9.5, 20 GET booboo FUNCTION '*HT \<Retry;\<Cancel' ;
   SIZE 1.5, 10, 0.667 ;
   FONT "MS Sans Serif", 8 ;
   STYLE "B"

READ CYCLE
RELEASE WINDOW err

ON ERROR DO errhand WITH ;
   ERROR(),    ;
   MESSAGE(),  ;
   MESSAGE(1), ;
   LINENO()

IF booboo = 'Retry'
   RETURN
ELSE
   ON ERROR
   POP MENU _msysmenu
   CANCEL
ENDIF ( booboo = 'Retry' )

RETURN


*!*****************************************************************************
*!
*!      Procedure: NoMem
*!
*!*****************************************************************************
PROCEDURE nomem
   DEFINE WINDOW nomem ;
      AT  0.000, 0.000  ;
      SIZE 10.071,74.200 ;
      TITLE "* Out of Memory *" ;
      FONT "Arial", 8 ;
      STYLE "B" ;
      FLOAT ;
      NOCLOSE ;
      MINIMIZE ;
      SYSTEM ;
      COLOR RGB(,,,255,0,0)
   MOVE WINDOW nomem CENTER

IF WVISIBLE("nomem")
   ACTIVATE WINDOW nomem SAME
ELSE
   ACTIVATE WINDOW nomem NOSHOW
ENDIF ( WVISIBLE("nomem") )
@ 7.071,31.600 GET nomem ;
   PICTURE "@*HT \<Ok" ;
   SIZE 1.769,9.167,0.667 ;
   DEFAULT 1 ;
   FONT "MS Sans Serif", 8 ;
   STYLE "B"
@ 2.286,9.400 SAY "There is not enough memory to perform function,"  ;
   FONT "Arial", 8 ;
   STYLE "BT"
@ 3.429,7.400 SAY "close some other Windows applications and try again."  ;
   FONT "Arial", 8 ;
   STYLE "BT"

IF NOT WVISIBLE("nomem")
   ACTIVATE WINDOW nomem
ENDIF ( NOT WVISIBLE("nomem") )

READ CYCLE

RELEASE WINDOW nomem
RETURN



*!*****************************************************************************
*!
*!      Procedure: CAUTION
*!
*!*****************************************************************************
PROCEDURE caution
PARAMETERS cautitle, msgstring

IF NOT WEXIST("caution")
   DEFINE WINDOW caution ;
      AT 19.167, 15.000 ;
      SIZE 7.308,95.000 ;
      TITLE '*** ' + cautitle + ' ***';
      FONT "MS Sans Serif", 8 ;
      FLOAT ;
      NOCLOSE ;
      MINIMIZE ;
      SYSTEM ;
      COLOR RGB(,,,255,0,0)
ENDIF ( NOT WEXIST("caution") )

MOVE WINDOW caution CENTER

IF WVISIBLE("caution")
   ACTIVATE WINDOW caution SAME
ELSE
   ACTIVATE WINDOW caution NOSHOW
ENDIF ( WVISIBLE("caution") )
STORE WCOLS("caution")/2 TO wincenter
STORE LEN(msgstring)/2 TO mcenter
STORE 0 TO nothing

@1, (wincenter  - mcenter) - 2 SAY msgstring;
   COLOR RGB(0,0,0,255,255,0);
   FONT "MS Sans Serif", 9 ;
   STYLE "B"

@ 2.769, (wincenter  - 4.3) GET nothing ;
   PICTURE "@*HT \<Ok" ;
   SIZE 1.769,8.667,0.667 ;
   FONT "MS Sans Serif", 8 ;
   STYLE "B"

READ CYCLE
CLEAR
DEACTIVATE WINDOW caution
RELEASE WINDOW caution

RETURN
*.............   EOF:  ERR.PRG  ................*
Register to add this FAQ to your archive
Register to rate this FAQ  : BAD 1 2 3 4 5 6 7 8 9 10 GOOD
Please Note: 1 is Bad, 10 is Good :-)

Part and Inventory Search

Back
Top