Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive   : ERRLOG2.ZIP
Filename : ERRORLOG.PRG

 
Output of file : ERRORLOG.PRG contained in archive : ERRLOG2.ZIP
* ERRORLOG
*
* Clipper error system. Debugging version with log support
*
* Original code provided by Nantucket
* Original code for LogMemVar() was provided by Joe Booth and
* Steve Straley, Additionally the idea for logging errors came from
* Steve's second book.
*
* Enhancements (mainly anything that begins with Log) authored by Chuck Fox
*
*****************************************************************
*
* USE THIS PROGRAM AT YOUR OWN RISK !!!
* This program is released to Public Domain, so do what you will
* with it. (i.e., no royalties or payment of any type is expected)
*
*****************************************************************
*
* Many of the functions used in this program are contained in the
* Funcky.Lib provided by DLesko Associates.
*
* Description: This is an attempt to provide a comprehensive
* picture of the program's environment at any time.
* When an error occurs the log error function is called
* and at run-time a call may be made to LogError to perform
* a run-time report of the environment. The Error.Log that is
* created will rapidly grow to enormous proportions if care is
* not taken to remove it once in a while. (this is especially
* true if you tend to test under live conditions, where as
* everyone - including Murphy - knows that every thing will
* go wrong)
*
*
PROCEDURE Errorsys

RETURN


***
* Expr_Error(Name, Line, Info, Model, _1, _2, _3)
*

FUNCTION Expr_Error
PARAM Name, Line, Info, Model, _1, _2, _3, _4, _5
PRIVATE Sample

M->Sample = M->Model
M->Sample = STRTRAN(M->Sample, "_1", TYPE("M->_1"))
M->Sample = STRTRAN(M->Sample, "_2", TYPE("M->_2"))
M->Sample = STRTRAN(M->Sample, "_3", TYPE("M->_3"))

Logerr(2)

IF M->Info = "zero divide"
IF "%" $ M->Model
RETU M->_1
ELSE
RETU 0
ENDIF
ENDIF

ALTD(2)

IF TYPE("M->Result") != "U"
RETU M->Result
END

IF (LASTKEY() == 27)
RETU .F.
ENDIF

BREAK

RETURN .T.


***
* Misc_Error(Name, Line, Info, Model)
*

FUNCTION Misc_Error
PARAM Name, Line, Info, Model, _1, _2, _3, _4, _5

Logerr(3)

ALTD(2)

IF (LASTKEY() == 27)
RETU .F.
ENDIF

BREAK

RETURN .F.


***
* Open_Error(Name, Line, Info, Model, _1)
*

FUNCTION Open_Error
PARAM Name, Line, Info, Model, _1, _2, _3, _4, _5
Logerr(5)

ALTD(2)

IF NETERR() .AND. Model == "USE"
RETU(.F.)
ENDIF

IF (LASTKEY() == 27)
RETU .F.
ENDIF

RETURN .T.


***
* Undef_Error(Name, Line, Info, Model, _1)
*

FUNCTION Undef_Error
PARAM Name, Line, Info, Model, _1, _2, _3, _4, _5

Logerr(4)

ALTD(2)

IF (LASTKEY() == 27)
BREAK
END

RETURN .T.


***
* Print_Error(Name, Line)
*
FUNCTION Print_Error
PARAM Name, Line, Info, Model, _1, _2, _3, _4, _5
PRIVATE Key, File, Info

Info = "Printer Error"

Logerr(6)
@ 24, 0 SAY "Press gnore, etry, REAK, F, uit..."

DO WHILE .T.
Key = UPPER(CHR(INKey(0)))

IF (M->Key == "Q")
QUIT

ELSEIF (M->Key == "I")
@ 23,0
@ 24,0
RETU .F.

ELSEIF (M->Key == "R")
@ 23,0
@ 24,0
RETU .T.

ELSEIF (M->Key == "B")
@ 23,0
@ 24,0
BREAK

ELSEIF (M->Key == "F")
@ 23,0
@ 24,0
ACCEPT "FileName - " TO File
SET PRINTER TO (M->File)
@ 23,0
@ 24,0
RETU .T.

END
END

RETURN .F.


***
* Db_Error(Name, Line, Info)
*

FUNCTION Db_Error
PARAM Name, Line, Info, Model, _1, _2, _3, _4, _5
Logerr(1)
ALTD(2)
IF Info = 'lock required'
@ 24,0 SAY StrCenter(" Press Esc to abort, any other key to attempt to lock the record ")
IF INKEY(0) # 27
IF RLOCK()
RETU .T.
ENDIF
ENDIF
ENDIF

BREAK

RETURN .F.


PROCEDURE LogError
LogErr(0)
RETURN

FUNCTION LogErr
PARAMETERS LogError
PRIVATE OldColor, ErrScreen, LogError

* find out if it was called without parms
*****************************************
IF PCOUNT() = 0
Logerror = 0
ENDIF

* now type all the miscellaneous info
***************************************
IF TYPE("Info") $ "U"
Info = ""
ENDIF
IF TYPE("Model") $ "U"
Model = ""
ENDIF
IF TYPE("_1") $ "U"
_1 = ""
ENDIF
IF TYPE("_2") $ "U"
_2 = ""
ENDIF
IF TYPE("_3") $ "U"
_3 = ""
ENDIF
IF TYPE("_4") $ "U"
_4 = ""
ENDIF
IF TYPE("_5") $ "U"
_5 = ""
ENDIF
IF MEMORY(0) > 4
ErrScreen = SAVESCREEN()
ENDIF
OldColor = SETCOLOR("W/R")

Control = GETE("CLIPPER")
L_At = AT("l",LOWER(Control))
Control = IF(L_At > 0, SUBSTR(Control,L_At + 1), "11111111")
Control = IF(LEN(Control) < 8, SUBSTR(Control+"11111111",1,8),Control)
UserVersion = (UPPER(SUBSTR(Control,1,1)) = "U")
IF UserVersion
M_Message(" A Run-Time Error has been detected and is being logged ")
INKEY(3)
ELSE
IF LogError = 0
M_Message(" Creating Run-time Environment Report ")
ELSE
MsgOne = IF(UPPER(SUBSTR(Info,1,1)) $ "AEIOU"," An ", " A ")
MsgOne = MsgOne + Info + " has occurred "
MsgTwo = " in Procedure/Function "+UPPER(Name)
MsgThree = " at line number "+LTRIM(TRANSFORM(Line,"999,999"))
LongMsg(MsgOne,MsgTwo,MsgThree)
ENDIF
ENDIF
ErrFile = "Error.Log"
IF Handles() = 0
M_Message("No file handles available for error log file...Procedure aborted !")
INKEY(0)
RETU(.T.)
ENDIF

FirstEntry = .T.
IF !File(ErrFile)
Errhandle = FCREATE(ErrFile,0)
ELSE
IF UserVersion
Errhandle = FOPEN(ErrFile,1)

ELSEIF M_Query(" Erase current error log file ? ")
Errhandle = FCREATE(ErrFile,0)

ELSE
Errhandle = FOPEN(ErrFile,1)
FirstEntry = .F.

ENDIF
ENDIF

FBot(Errhandle)
OldAltHand = AltHandle(Errhandle)
IF !FirstEntry
?
ENDIF

SET CONSOLE OFF
Title = IF(Logerror=0,"RUN TIME REPORT FOR ","ERROR LOG FOR ")
?? "É"+REPLICATE("Í",78)+"»"
LogTime = " Logged on "+DTOW(DATE())+" at "+TIME()
? "º"+STRCENTER(Title+PROGRAM()+LogTime,78)+"º"
? "È"+REPLICATE("Í",78)+"¼"

LogBasic()
IF !UserVersion
IF !M_Query("Basic Clipper Error System Information Logged...Produce Long Report ? ")
SET CONSOLE OFF
? STRCENTER("*** End of Error "+LogTime+" - Short Form ***",78)
?
SET CONSOLE ON
SET ALTERNATE OFF
CLOSE ALTERNATE
IF OldAltHand > 0
AltHandle(OldAltHand)
ENDIF
RETU(.T.)
ENDIF
ENDIF
SET CONSOLE OFF
LogScreen()
LogDbf()
LogMemVars()
LogSets()
LogHotKey()
IF FirstEntry
LogDisk()
LogHard()
ENDIF
IF TYPE("ErrScreen") = "C"
SETCOLOR(OldColor)
RESTORE SCREEN FROM ErrScreen
ENDIF
SETCOLOR("W/R")
?
? STRCENTER("*** End of Error "+LogTime+" - Long Form ***",78)
?
SET ALTERNATE OFF
CLOSE ALTERNATE
SET CONSOLE ON
IF OldAltHand > 0
AltHandle(OldAltHand)
ENDIF
IF UserVersion
M_Message(" Please contact Programming Support ")
SETCOLOR("R/W")
@ 24,00 SAY StrCenter(" Press any key to Quit ",80)
CLOSE ALL
INKEY(0)
QUIT
ELSE
IF M_Query(" View Error Log File ? ")
Cls(7,"±")
String = M_View(2,2,22,77,ErrFile)
ELSE
IF M_Query(" Print Error Log File ? ")
IF IsQueue()
Q_Submit("ErrFile")
ELSE
M_Message(" Can't access Print Spooler....Procedure Aborted ")
ENDIF
ENDIF
ENDIF
ENDIF
SETCOLOR(OldColor)
RETURN(.T.)


FUNCTION LogDisk
IF SUBSTR(Control,8,1) = "0"
RETU(.T.)
ENDIF
IF TYPE("ErrScreen") = "C"
SETCOLOR(OldColor)
RESTORE SCREEN FROM ErrScreen
ENDIF
SETCOLOR("W/R")
M_Message(" Logging Hard Disk and DOS ")
Tab = SPACE(21)
?
?
? StrCenter("DOS MEMORY ENVIRONMENT")
?
? Tab + " DOS Version : "+TRANSFORM(DOSVERS(),"9.99")
? Tab + " DOS Memory Total : "+TRANSFORM(DOSMEM()*1024,"999,999,999")+" Bytes "
? Tab + " DOS Memory Free : "+TRANSFORM(Fre(),"999,999,999")+" Bytes"
? Tab + " Maximum Handles : "+TRANSFORM(MAXHANDLES(),"999")
? Tab + " Avail Handles : "+TRANSFORM(HANDLES(),"999")+SPACE(17)
? Tab + " Avail Extend Mem : "+TRANSFORM(EXTMEM()*1024,"999,999,999")+" Bytes"
? Tab + " Avail Expand Mem : "+IF(ISEMS(),TRANSFORM(EXPMEM()*1024,"999,999,999")+" Bytes ","None")
? Tab + " DOS COMSPEC : "+IF(Alltrimlen(GETE("COMSPEC"))=0,"None",SUBSTR(GETE("COMSPEC"),1,39))
DosPath = GETE("PATH")
DosPathLen = Alltrimlen(DosPath)
? Tab + " DOS PATH : "+IF(DosPathLen = 0,"None",SUBSTR(DosPath,1,35)+IF(DosPathLen > 35," +",""))

IF DosPathLen > 35
? Tab + SPACE(18)+": "+SUBSTR(DosPath,36,35)+IF(DosPathLen>70," +","")

IF DosPathLen > 70
? Tab + SPACE(18)+": "+SUBSTR(DosPath,70,35)+IF(DosPathLen>105," +","")

IF DosPathLen > 105
? SPACE(18)+": "+SUBSTR(DosPath,105,23)+IF(DosPathLen>128," ...more","")

ENDIF
ENDIF
ENDIF
?
? StrCenter("CLIPPER MEMORY ENVIRONMENT")
?
? Tab + " Avail Free Pool : "+TRANSFORM(MEMORY(0)*1024,"999,999,999")+" Bytes"
? Tab + " DOS Set CLIPPER : "+IF(Alltrimlen(GETE("CLIPPER"))=0,"None",SUBSTR(GETE("CLIPPER"),1,39))
?
?
? StrCenter("DISK",80)
?
? Tab + " Volume Label : "+IF(Alltrimlen(GETVOLUME())=0,"None",GETVOLUME())
? Tab + " Free Disk Space : "+TRANSFORM(DISKSPACE(),"999,999,999")+" Bytes"
? Tab + " Total Disk Space : "+TRANSFORM(DISKSIZE(),"999,999,999")+" Bytes "
? Tab + " Number of Drives : "+TRANSFORM(DRIVES(),"99")+SPACE(18)
CurrDir = CURDIR()
? Tab + " Current Directory: "+SUBSTR(CurrDir,1,39)
Dstr = DriveStr()
Dstr = IF(SUBSTR(Dstr,1,1)="A",SUBSTR(Dstr,2),DStr)
Dstr = IF(SUBSTR(Dstr,1,1)="B",SUBSTR(Dstr,2),DStr)
FOR Ctr = 1 TO LEN(Dstr)
DriveLetter = SUBSTR(Dstr,Ctr,1)
IF IsDrive(DriveLetter+":")
IF CURDIR() # CurrDir
? Tab + " Directory of "+DriveLetter+" : "+SUBSTR(CURDIR(DriveLetter),1,39)
ENDIF

ELSE
? Tab + " Directory of "+DriveLetter+" : Drive not ready"
ENDIF
NEXT

RETURN(.T.)


FUNCTION LogScreen
IF SUBSTR(Control,2,1) = "0"
RETU(.T.)
ENDIF
IF TYPE("ErrScreen") = "C"
SETCOLOR(OldColor)
RESTORE SCREEN FROM ErrScreen
ENDIF
ScreenVar = ReadScreen(0,0,2000)
SETCOLOR("W/R")
M_Message(" Logging Screen Variables ")
?
?
? StrCenter("SCREEN CONTENTS",80)
?
Markers = (SUBSTR(Control,1,1) = "1")
IF Markers
? ' [Top of Screen] 2 3 4 5 6 7'
? ' 01234567890123456789012345678901234567890123456789012345678901234567890123456789'
?
ENDIF
FOR Ctr = 0 TO 24
? IF(Markers,STR(Ctr,2,0)+":","")+SUBSTR(ScreenVar,(Ctr * 80) + 1,80)
NEXT
IF Markers
?
? ' 01234567890123456789012345678901234567890123456789012345678901234567890123456789'
? ' [Bottom of Screen] 2 3 4 5 6 7'
ENDIF
RELEASE ScreenVar
RETURN(.T.)


FUNCTION LogHard
IF SUBSTR(Control,3,1) = "0"
RETU(.T.)
ENDIF
IF TYPE("ErrScreen") = "C"
SETCOLOR(OldColor)
RESTORE SCREEN FROM ErrScreen
ENDIF
SETCOLOR("W/R")
M_Message(" Logging Hardware Configuration and Status ")
Tab = SPACE(21)
?
?
? StrCenter("SYSTEM IDENTIFICATION",80)
?
? Tab + " System Type : "+SysId()
? Tab + " CPU Type : "+TRANSFORM(CPUTYPE(),"99999")
? Tab + " Monitor Type : "+Monitor()
IF VidType() = 2 .OR. VidType() = 3
? Tab + " Video Memory : "+TRANSFORM(EGAMEM()*1024,"999,999,999")+" Bytes"
ENDIF
? Tab + " Co-Processor : "+IF(NDPTYPE()=0,"None ",TRANSFORM(NDPTYPE(),"99999"))
?
?
? StrCenter("KEYBOARD STATUS",80)
?
? Tab + " Caps Lock : "+IF(CapsLock(),"On ","Off")
? Tab + " Num Lock : "+IF(NumLock(),"On ","Off")
? Tab + " Scroll Lock : "+IF(ScrLock(),"On ","Off")
? Tab + " Insert : "+IF(Insert(),"On ","Off")
? Tab + " Last Key : "+STR(LASTKEY(),3,0)
? Tab + " Mouse : "+IF(ISMOUSE(),"Installed","None ")
?
?
? StrCenter("COMMUNICATIONS PORTS",80)
?
? Tab + " Comm Port 1 : "+IF(ISCOM(1),"Installed","None ")
? Tab + " Comm Port 2 : "+IF(ISCOM(2),"Installed","None ")
? Tab + " Comm Port 3 : "+IF(ISCOM(3),"Installed","None ")
? Tab + " Comm Port 4 : "+IF(ISCOM(4),"Installed","None ")
?
?
? StrCenter("PRINTERS",80)
?
? Tab + " Printer 1 : "+Print_Stat(1)
? Tab + " Printer 2 : "+Print_Stat(2)
? Tab + " Printer 3 : "+Print_Stat(3)
RETURN(.T.)


FUNCTION LogSets
IF SUBSTR(Control,4,1) = "0"
RETU(.T.)
ENDIF
IF TYPE("ErrScreen") = "C"
SETCOLOR(OldColor)
RESTORE SCREEN FROM ErrScreen
ENDIF
SETCOLOR("W/R")
M_Message(" Logging Clipper Set Environment ")
?
?
? StrCenter("CLIPPER SET ENVIRONMENT ",80)
?
Tab = SPACE(7)
? Tab + " Alternate : "+IF(STATUS(1),"On ", "Off") + SPACE(17)
?? " Exact : "+IF(STATUS(10),"On ","Off")
? Tab + " Bell : "+IF(STATUS(2),"On ", "Off") + SPACE(17)
?? " Exclusive : "+IF(STATUS(11),"ON.","Off")
? Tab + " Century : "+IF(STATUS(3),"On ", "Off") + SPACE(17)
?? " Fixed : "+IF(STATUS(12),"On ","Off")
? Tab + " Confirm : "+IF(STATUS(4),"On ", "Off") + SPACE(17)
?? " Insert : "+IF(STATUS(13),"On ","Off")
? Tab + " Console : "+IF(STATUS(5),"On ", "Off") + SPACE(17)
?? " Intensity : "+IF(STATUS(14),"On ","Off")
? Tab + " Cursor : "+IF(STATUS(6),"On ", "Off") + SPACE(17)
?? " Margin : "+LTRIM(STR(Margin()))
? Tab + " Date Type : "+DateTypeSt() + SPACE(11)
?? " Path : "++IF(Alltrimlen(Path()) = 0,"None",SUBSTR(Path()+SPACE(20),1,20))
? Tab + " Decimals : "+STR(Decimals(),2,0) + SPACE(18)
?? " Print : "+IF(STATUS(15),"On ","Off")
? Tab + " Default : "+IF(Alltrimlen(Default()) = 0,"None",SUBSTR(Default()+SPACE(20),1,20))
?? " Scoreboard : "+IF(STATUS(16),"On ","Off")
? Tab + " Deleted : "+IF(STATUS(7),"On ", "Off") + SPACE(17)
?? " Softseek : "+IF(STATUS(17),"On ","Off")
? Tab + " Delimiters : "+IF(STATUS(8),"On "+Delimiters(), "Off ") + SPACE(15)
?? " Unique : "+IF(STATUS(18),"On ","Off")
? Tab + " Escape : "+IF(STATUS(9),"On ", "Off") + SPACE(17)
?? " Wrap : "+IF(STATUS(19),"On ","Off")
RETURN(.T.)


FUNCTION LogHotKey
PRIVATE Ctr
IF SUBSTR(Control,5,1) = "0"
RETU(.T.)
ENDIF
IF TYPE("ErrScreen") = "C"
SETCOLOR(OldColor)
RESTORE SCREEN FROM ErrScreen
ENDIF
SETCOLOR("W/R")
M_Message(" Logging Hot Key Procedures ")
?
?
? StrCenter(" SET KEY PROCEDURES ",80)
?
? SPACE(14) + " Inkey Value " + SPACE(8) + "Key Name" + SPACE(11) + "Procedure"
?
FOR Ctr = -50 TO 400
IF Ctr # 0
IF IsKeySet(Ctr)
? SPACE(16)+" Key "+TRANSFORM(Ctr,"999")+SPACE(10)
IF Ctr >= -39 .AND. Ctr <= -30
?? Pad(" Alt-F"+LTRIM(STR((((Ctr * -1) % 10) + 1),2,0)),10)
ELSEIF Ctr >= -29 .AND. Ctr <= -20
?? Pad(" Ctrl-F"+LTRIM(STR((((Ctr * -1) % 10) + 1),2,0)),10)
ELSEIF Ctr >= -19 .AND. Ctr <= -10
?? Pad(" Shift-F"+LTRIM(STR((((Ctr * -1) % 10) + 1),2,0)),10)
ELSEIF Ctr >= -9 .AND. Ctr <= -1
?? Pad(" F"+LTRIM(STR((((Ctr * -1) % 10) + 1),2,0)),10)
ELSEIF Ctr = 1
?? " Home "
ELSEIF Ctr = 2
?? " ^R Arrow "
ELSEIF Ctr = 3
?? " PgDn "
ELSEIF Ctr = 4
?? " R Arrow "
ELSEIF Ctr = 5
?? " U Arrow "
ELSEIF Ctr = 6
?? " End "
ELSEIF Ctr = 7
?? " Del "
ELSEIF Ctr = 8
?? " BkSpace "
ELSEIF Ctr = 9
?? " Tab "
ELSEIF Ctr = 10
?? " Ctrl-J "
ELSEIF Ctr = 11
?? " Ctrl-K "
ELSEIF Ctr = 12
?? " Ctrl-L "
ELSEIF Ctr = 13
?? " Enter "
ELSEIF Ctr = 14
?? " Ctrl-N "
ELSEIF Ctr = 15
?? " Ctrl-O "
ELSEIF Ctr = 16
?? " Ctrl-P "
ELSEIF Ctr = 17
?? " Ctrl-Q "
ELSEIF Ctr = 18
?? " PgUp "
ELSEIF Ctr = 19
?? " L Arrow "
ELSEIF Ctr = 20
?? " Ctrl-T "
ELSEIF Ctr = 21
?? " Ctrl-U "
ELSEIF Ctr = 22
?? " Ins "
ELSEIF Ctr = 23
?? " Ctrl-End "
ELSEIF Ctr = 24
?? " D Arrow "
ELSEIF Ctr = 25
?? " Ctrl-Y "
ELSEIF Ctr = 26
?? " ^L Arrow "
ELSEIF Ctr = 27
?? " Esc "
ELSEIF Ctr = 28
?? " F1 "
ELSEIF Ctr = 29
?? " ^Home "
ELSEIF Ctr = 30
?? " ^PgDn "
ELSEIF Ctr = 31
?? " ^PgUp "
ELSEIF Ctr = 32
?? " Space "
ELSEIF Ctr >= 33 .AND. Ctr <= 126
?? SPACE(1) + CHR(Ctr) + SPACE(8)
ELSEIF Ctr = 127
?? " ^BkSpace "
ELSEIF Ctr >= 128 .AND. Ctr <= 255
?? SPACE(1) + CHR(Ctr) + SPACE(8)
ELSEIF Ctr = 259
?? " ^BkSpace "
ELSEIF Ctr = 271
?? " BackTab "
ELSEIF Ctr = 272
?? " Alt-Q "
ELSEIF Ctr = 273
?? " Alt-W "
ELSEIF Ctr = 274
?? " Alt-E "
ELSEIF Ctr = 275
?? " Alt-R "
ELSEIF Ctr = 276
?? " Alt-T "
ELSEIF Ctr = 277
?? " Alt-Y "
ELSEIF Ctr = 278
?? " Alt-U "
ELSEIF Ctr = 279
?? " Alt-I "
ELSEIF Ctr = 280
?? " Alt-O "
ELSEIF Ctr = 281
?? " Alt-P "
ELSEIF Ctr = 286
?? " Alt-A "
ELSEIF Ctr = 287
?? " Alt-S "
ELSEIF Ctr = 288
?? " Alt-D "
ELSEIF Ctr = 289
?? " Alt-F "
ELSEIF Ctr = 290
?? " Alt-G "
ELSEIF Ctr = 291
?? " Alt-H "
ELSEIF Ctr = 292
?? " Alt-J "
ELSEIF Ctr = 293
?? " Alt-K "
ELSEIF Ctr = 294
?? " Alt-L "
ELSEIF Ctr = 300
?? " Alt-Z "
ELSEIF Ctr = 301
?? " Alt-X "
ELSEIF Ctr = 302
?? " Alt-C "
ELSEIF Ctr = 303
?? " Alt-V "
ELSEIF Ctr = 304
?? " Alt-B "
ELSEIF Ctr = 305
?? " Alt-N "
ELSEIF Ctr = 306
?? " Alt-M "
ELSEIF Ctr = 376
?? " Alt-1 "
ELSEIF Ctr = 377
?? " Alt-2 "
ELSEIF Ctr = 378
?? " Alt-3 "
ELSEIF Ctr = 379
?? " Alt-4 "
ELSEIF Ctr = 380
?? " Alt-5 "
ELSEIF Ctr = 381
?? " Alt-6 "
ELSEIF Ctr = 382
?? " Alt-7 "
ELSEIF Ctr = 383
?? " Alt-8 "
ELSEIF Ctr = 384
?? " Alt-9 "
ELSEIF Ctr = 385
?? " Alt-0 "
ELSEIF Ctr = 386
?? " Alt-- "
ELSEIF Ctr = 387
?? " Alt-= "
ELSE
?? SPACE(10)
ENDIF
?? +SPACE(10)+SetKey(Ctr)
ENDIF
ENDIF
NEXT
?
RETURN(.T.)


FUNCTION LogMemVars
IF SUBSTR(Control,6,1) = "0"
RETU(.T.)
ENDIF
IF TYPE("ErrScreen") = "C"
SETCOLOR(OldColor)
RESTORE SCREEN FROM ErrScreen
ENDIF
SETCOLOR("W/R")
M_Message(" Logging Memory Variables ")
IF Handles() = 0
M_Data(22,1)
M_Message("No file handles available for error log memory file")
RETU(.T.)
ENDIF
MFile = "SAVEMEM.MEM"
SAVE ALL TO (MFile)
?
? StrCenter("MEMORY VARIABLES",80)
?
MemHandle = FOPEN(MFile)
MemFileLen = FSEEK(MemHandle,0,2)
MCharLog = SPACE(1)
FSEEK(MemHandle,0)
STORE 0 TO N__, TB_
IF MemFileLen < 2
? 'THERE ARE NO MEMORY VARIABLES PRESENT.'
?
ELSE
? " Var Name Type Len Contents "
?
?
DO WHILE FSEEK(MemHandle,0,1) + 1 < MemFileLen
MW_ = SPACE(18)
FREAD(MemHandle,@MW_,18)
VarName = LEFT(MW_,AT(CHR(0),MW_)-1)
VarType = SUBSTR(MW_,12,1)
VR_ = BIN2W(RIGHT(MW_,2))
IF !(VarType $ (CHR(195)+CHR(204)+CHR(196)+CHR(206)))
FCLOSE(MemHandle)
RETU(.T.)
ENDIF
MC_ = 14
FSEEK(MemHandle,MC_,1)
IF VarType$CHR(195)+CHR(204)
TB_ = TB_ + VR_
MCHARLOG = SPACE(VR_)
FREAD(MemHandle,@MCHARLOG,VR_)
* take care of the null terminator
MCharLog = SUBSTR(MCharLog,1,LEN(MCharLog)-1)
ELSE
TB_ = TB_ + 8
MNUMERIC = SPACE(8)
FREAD(MemHandle,@MNUMERIC,8)
P1 = ASC(SUBSTR(MNUMERIC,8,1))
P1 = (P1 % 128) *16
P2 = INT(ASC(SUBSTR(MNUMERIC,7,1))/16)
POWER = P1 + P2 - 1023
MINUS = INT(ASC(SUBSTR(MNUMERIC,8,1)) /16) >= 8
MANT0 = ASC(SUBSTR(MNUMERIC,7,1))
MANT0 = (MANT0 % 16) /16
MANT1 = BIN2W(SUBSTR(MNUMERIC,5,2)) / (65536 * 16)
MANT2 = BIN2W(SUBSTR(MNUMERIC,3,2)) / (65536 * 65536 * 16)
MANT3 = BIN2W(SUBSTR(MNUMERIC,1,2)) / (65536 * 65536 * 65536 * 16)
MANTISSA = MANT0 + MANT1 + MANT2 + MANT3
NUMVAL = IF(MINUS, (-1 + MANTISSA) * (2^POWER),(1 + MANTISSA) * (2^POWER))
SHOWDEC = ASC(RIGHT(MW_,1))
ENDIF
?? SPACE(2)+VarName+SPACE(12-LEN(VarName))
CharLen = LTRIM(STR(LEN(MCharLog)))
CharLen = SPACE(2) + CharLen + SPACE(6 - LEN(CharLen))
IF VarType = CHR(195) .AND. VR_ > 51
FWRITE(Errhandle,' C ')
?? CharLen+'"'+LEFT(MCharLog,50)+'"'
ELSE
DO CASE
CASE VarType = CHR(195)
?? ' C '
?? CharLen+["]+MCharLog+["]
CASE VarType = CHR(204)
?? ' L 1 '
?? IF(ASC(MCharLog)#0,'.T.','.F.')
CASE VarType = CHR(206)
?? ' N '
NumLen = LTRIM(STR(NumLength(NumVal)))+"."+LTRIM(STR(ShowDec))
NumLen = SPACE(2) + NumLen + SPACE(6 - LEN(NumLen))
?? NumLen
?? LTRIM(STR(NUMVAL,20,SHOWDEC))
CASE VarType = CHR(196)
?? ' D 8 '
?? DTOC(CTOD('01/01/0100')+NUMVAL-1757585)
ENDCASE
ENDIF
?
ENDDO
ENDIF
FCLOSE(MemHandle)
Ferase(MFile)
RETURN(.T.)

FUNCTION LogDbf
PRIVATE AnyOpen
IF SUBSTR(Control,7,1) = "0"
RETU(.T.)
ENDIF
IF TYPE("ErrScreen") = "C"
SETCOLOR(OldColor)
RESTORE SCREEN FROM ErrScreen
ENDIF
SETCOLOR("W/R")
M_Message(" Logging Database Information ")
AnyOpen = .F.
?
? StrCenter(" DATABASE INFORMATION ")
?
IF SELECT() = 0
? " No Area Selected "
ELSE
AreaSelected = SELECT()
ENDIF
LineSep = " * * *"+SPACE(28) + "* * *" + SPACE(28) + "* * *"
? LineSep
?
FOR Out_Ctr = 1 TO 254
IF Alltrimlen(ALIAS(Out_Ctr)) > 0
AnyOpen = .T.
SELECT (Out_Ctr)
? IF(SELECT()#AreaSelected," Area : "," Selected Area: ")+ ;
LTRIM(STR(SELECT()))+" Ä "
?? ALIAS()
? " Record Number: " + ALLTRIM(TRANSFORM(RECNO(), ;
"@B 999,999"))+" of "+ALLTRIM(TRANSFORM(RECCOUNT(),"@B 999,999"))+ ;
IF(DELETED()," ","")+;
IF(EOF() .AND. !BOF()," ","")+;
IF(BOF() .AND. !EOF()," ","")+;
IF(RECCOUNT() = 0," ","")
? " Last Updated : "+DTOC(LUPDATE())
?
FOR In_Ctr = 1 TO 15
Rstring = DBRELATION(In_Ctr)
IF Alltrimlen(Rstring) > 0
? " Relation : "+LTRIM(STR(In_Ctr))+" Ä "+TRIM(Rstring)
?? " INTO "+ALIAS(DBRSELECT(In_Ctr))
ELSE
IF In_Ctr = 1
? " Relation : None"
EXIT
ENDIF
ENDIF
NEXT
?
IF Alltrimlen(DBFILTER()) > 0
? " Filter : "+DBFILTER()
ELSE
? " Filter : None"
ENDIF
?
IF ISINDEX()
Ntx_Cont = INDEXORD()
FOR In_Ctr = 1 to 15
Ntx_Key = INDEXKey(In_Ctr)
IF Alltrimlen(Ntx_Key) > 0
? " Index : "+LTRIM(STR(In_Ctr,2,0))+" Ä "+SUBSTR(INDEXKey(In_Ctr)+SPACE(50),1,47)
?? IF(In_Ctr = Ntx_Cont,"Primary ","Secondary ")
ELSE
EXIT
ENDIF
NEXT
ELSE
? " Index : None"
ENDIF
IF FirstEntry
?
? " Field Name Type Len Dec Field Contents "
?
NumFields = FCOUNT()
DECLARE Fields[NumFields], Type[NumFields], ;
Decimals[NumFields], Length[NumFields]
AFILL(Fields,"")
AFILL(Type,"")
AFILL(Length,"")
AFILL(Decimals,"")
AFIELDS(Fields,Type,Length,Decimals)
FOR Ctr = 1 TO NumFields
FieldName = FIELDNAME(Ctr)
? SPACE(1) + Pad(Fields[Ctr],10) + SPACE(4) + TYPE[Ctr] + SPACE(3)
?? STR(Length[Ctr],3,0) + SPACE(3)
?? STR(Decimals[Ctr],2,0) + SPACE(3)
IF Type[Ctr] = "C"
?? SUBSTR(&FieldName.,1,50)
ELSEIF Type[Ctr] $ "NDL"
?? &FieldName.
ELSEIF Type[Ctr] = "M"
?? MEMOLINE(FieldName,50)
ENDIF

NEXT
RELEASE Fields, Type, Length, Decimals
ENDIF
?
? LineSep
?
ENDIF
NEXT
IF !AnyOpen
? " No Databases Open "
?
? LineSep
?
ENDIF
RETURN(0)


FUNCTION Print_Stat
PARAMETER Port_Num
PRIVATE Prt_Stat, StatMsg
Prt_stat = Prnstatus(IF(TYPE("Port_Num")="N",Port_Num,1))
DO CASE
CASE Prt_Stat = 0
StatMsg = "On-Line "

CASE Prt_Stat = 1
StatMsg = "Off-Line "

CASE Prt_Stat = 2
StatMsg = "Turned Off "

CASE Prt_Stat = 3
StatMsg = "Out of Paper "

CASE Prt_Stat = 4
StatMsg = "Cable Not Connected "

OTHERWISE
StatMsg = "Status Unknown "
ENDCASE
RETURN(StatMsg)

FUNCTION DosErrMsg
PRIVATE Err_Num
Err_Num = DOSERROR()
DO CASE
CASE Err_Num = 0
Msg = "Unknown or No Error"
CASE Err_Num = 1
Msg = "Invalid function number"
CASE Err_Num = 2
Msg = "File not found"
CASE Err_Num = 3
Msg = "Path not found"
CASE Err_Num = 4
Msg = "Too many open Files (no handles left)"
CASE Err_Num = 5
Msg = "Access denied"
CASE Err_Num = 6
Msg = "Invalid handle"
CASE Err_Num = 7
Msg = "Memory control blocks destroyed"
CASE Err_Num = 8
Msg = "Insufficient memory"
CASE Err_Num = 9
Msg = "Invalid memory block address"
CASE Err_Num = 10
Msg = "Invalid environment"
CASE Err_Num = 11
Msg = "Invalid format"
CASE Err_Num = 12
Msg = "Invalid access code"
CASE Err_Num = 13
Msg = "Invalid data"
CASE Err_Num = 14
Msg = "Reserved"
CASE Err_Num = 15
Msg = "Invalid drive was specified"
CASE Err_Num = 16
Msg = "Attempt to remove current directory"
CASE Err_Num = 17
Msg = "Not same device"
CASE Err_Num = 18
Msg = "No more Files"
CASE Err_Num = 19
Msg = "Attempt to write on write-protected diskette"
CASE Err_Num = 20
Msg = "Unknown unit"
CASE Err_Num = 21
Msg = "Drive not ready"
CASE Err_Num = 22
Msg = "Unknown command"
CASE Err_Num = 23
Msg = "Data error (CRC)"
CASE Err_Num = 24
Msg = "Bad request structure length"
CASE Err_Num = 25
Msg = "Seek error"
CASE Err_Num = 26
Msg = "Unknown media type"
CASE Err_Num = 27
Msg = "Sector not found"
CASE Err_Num = 28
Msg = "Printer out of paper"
CASE Err_Num = 29
Msg = "Write fault"
CASE Err_Num = 30
Msg = "Read fault"
CASE Err_Num = 31
Msg = "General failure"
CASE Err_Num = 32
Msg = "Sharing violation"
CASE Err_Num = 33
Msg = "Lock violation"
CASE Err_Num = 34
Msg = "Invalid disk change"
CASE Err_Num = 35
Msg = "FCB unavailable"
CASE Err_Num = 36
Msg = "Sharing buffer overflow"
CASE Err_Num >= 37 .AND. Err_Num <= 49
Msg = "Reserved"
CASE Err_Num = 50
Msg = "Network request not supported"
CASE Err_Num = 51
Msg = "Remote computer not listening"
CASE Err_Num = 52
Msg = "Duplicate Name on network"
CASE Err_Num = 53
Msg = "Network Name not found"
CASE Err_Num = 54
Msg = "Network busy"
CASE Err_Num = 55
Msg = "Network device no longer exists"
CASE Err_Num = 56
Msg = "Network BIOS command limit exceeded"
CASE Err_Num = 57
Msg = "Network adapter hardware error"
CASE Err_Num = 58
Msg = "Incorrect response from network"
CASE Err_Num = 59
Msg = "Unexpected network error"
CASE Err_Num = 60
Msg = "Incompatible remote adapter"
CASE Err_Num = 61
Msg = "Print queue full"
CASE Err_Num = 62
Msg = "Not enough space for print File"
CASE Err_Num = 63
Msg = "Print File deleted (not enough space)"
CASE Err_Num = 64
Msg = "Network Name deleted"
CASE Err_Num = 65
Msg = "Access denied"
CASE Err_Num = 66
Msg = "Network device type incorrect"
CASE Err_Num = 67
Msg = "Network Name not found"
CASE Err_Num = 68
Msg = "Network Name limit exceeded"
CASE Err_Num = 69
Msg = "Network BIOS session limit exceeded"
CASE Err_Num = 70
Msg = "Temporarily paused"
CASE Err_Num = 71
Msg = "Network request not accepted"
CASE Err_Num = 72
Msg = "Print or disk redirection paused"
CASE Err_Num >= 73 .AND. Err_Num <= 79
Msg = "Reserved"
CASE Err_Num = 80
Msg = "File exists"
CASE Err_Num = 81
Msg = "Reserved"
CASE Err_Num = 82
Msg = "Cannot make directory entry"
CASE Err_Num = 83
Msg = "Fail on INT 24"
CASE Err_Num = 84
Msg = "Too many redirections"
CASE Err_Num = 85
Msg = "Duplicate redirection"
CASE Err_Num = 86
Msg = "Invalid password"
CASE Err_Num = 87
Msg = "Invalid parameter"
CASE Err_Num = 88
Msg = "Network device fault"
OTHERWISE
MSg = "No Message Available"
ENDCASE
RETURN(Msg)


FUNCTION Monitor
PRIVATE MType
MType = MONTYPE()
IF MType = 0
MStr = "No Display"
ELSEIF MType = 1
MStr = "MDA w/Mono Display "
ELSEIF MType = 2
MStr = "CGA w/Color Display "
ELSEIF MType = 4
MStr = "EGA w/Color Display "
ELSEIF MType = 5
MStr = "EGA w/Mono Display "
ELSEIF MType = 6
MStr = "PGA "
ELSEIF MType = 7
MStr = "VGA w/Mono Display "
ELSEIF MType = 8
MStr = "VGA w/Color Display "
ELSEIF MType = 10
MStr = "MCGA w/Digital Color"
ELSEIF MType = 11
MStr = "MCGA w/Analog Mono "
ELSEIF MType = 12
MStr = "MCGA w/Analog Color "
ELSE
MStr = "Unknown Monitor "
ENDIF
RETURN(MStr)


FUNCTION SysId
PRIVATE IDStr, IDByte, RomBiosDate
RomBiosDate = ROMDATE()
IDByte = SYSTYPE()
IF RomBiosDate = "04/24/81" .AND. IDByte = 255
IDStr = "IBM PC First Model "
ELSEIF RomBiosDate = "10/19/81" .AND. IDByte = 255
IDStr = "IBM PC - Bugs Fixed "
ELSEIF RomBiosDate = "08/16/82" .AND. IDByte = 254
IDStr = "IBM XT First Model "
ELSEIF RomBiosDate = "10/27/82" .AND. IDByte = 255
IDStr = "IBM PC w/Hard Disk "
ELSEIF RomBiosDate = "11/08/82" .AND. IDByte = 254
IDStr = "IBM Portable "
ELSEIF RomBiosDate = "06/01/83" .AND. IDByte = 253
IDStr = "IBM PC Jr. "
ELSEIF RomBiosDate = "01/10/84" .AND. IDByte = 252
IDStr = "IBM AT "
ELSEIF RomBiosDate = "06/10/85" .AND. IDByte = 252
IDStr = "IBM AT Revision 1 "
ELSEIF RomBiosDate = "09/13/85" .AND. IDByte = 249
IDStr = "IBM Convertible "
ELSEIF RomBiosDate = "11/15/85" .AND. IDByte = 252
IDStr = "IBM AT w/governer "
ELSEIF RomBiosDate = "01/10/86" .AND. IDByte = 251
IDStr = "IBM XT Revision 1 "
ELSEIF RomBiosDate = "04/21/86" .AND. IDByte = 252
IDStr = "IBM XT Sub Model 1 "
ELSEIF RomBiosDate = "05/09/86" .AND. IDByte = 251
IDStr = "IBM XT Revision 2 "
ELSEIF RomBiosDate = "09/02/86" .AND. IDByte = 250
IDStr = "IBM PS/2 30 "
ELSEIF RomBiosDate = "02/13/87" .AND. IDByte = 252
IDStr = "IBM PS/2 50 or 60 "
ELSEIF RomBiosDate = "03/30/87" .AND. IDByte = 248
IDStr = "IBM PS/2 80 16MHz "
ELSEIF RomBiosDate = "10/07/87" .AND. IDByte = 248
IDStr = "IBM PS/2 80 20MHz "
ELSE
IDStr = "Unknown Computer "
ENDIF
RETURN(IDStr)


FUNCTION DATETYPEST
PRIVATE DType, DStr
DType = DATETYPE()
IF DType = 1
DStr = "American "
ELSEIF DType = 2
DStr = "Ansi "
ELSEIF DType = 3
DStr = "British "
ELSEIF DType = 4
DStr = "French "
ELSEIF DType = 5
DStr = "German "
ELSEIF DType = 6
DStr = "Italian "
ENDIF
RETURN(DStr)


FUNCTION NumLength
PARAMETERS Number
IF ShowDec = 0
CharNum = STR(Number,19,0)
ELSE
CharNum = STR(Number,19,ShowDec)
ENDIF
RETURN(Alltrimlen(CharNum))


* FUNCTION PAD
* PARAMETERS String, PadLength
* RETURN(SUBSTR(String+SPACE(PadLength),1,PadLength))


FUNCTION LongMsg
PARAMETERS Msg1, Msg2, Msg3
box(6,4,16,76,"Õ͸³¾ÍÔ³",-1,1,8)
SetAttr(7,2,17,2,8)
Scroll(07,05,15,75,0,-1)
@ 9,5 SAY StrCenter(Msg1,70)
@ 11,5 SAY StrCenter(Msg2,70)
@ 13,5 SAY StrCenter(Msg3,70)
@ 24,0 SAY StrCenter(" Press any key to continue ")
INKEY(0)
RETURN 0

FUNCTION LogBasic
IF LogError > 0
?
? STRCENTER("BASIC ERROR INFORMATION",80)
?
PD = SPACE(21)
IF DOSERROR() > 0
? PD + " DOS Error "+SUBSTR(LTRIM(STR(DOSERROR()))+SPACE(7),1,7)+": "+ DosErrMsg()
ENDIF
DO CASE
CASE Logerror = 1 && Db_Error
? PD + " Database Error : "+UPPER(Info)
CASE Logerror = 2 && Expr_Error has additional parms MODEL, _1, _2, _3
? PD + " Expression Error : "+UPPER(Info)
CASE Logerror = 3 && Misc_Error Model
? PD + " Miscellaneous : "+UPPER(Info)
CASE Logerror = 4 && Undef_Error Model, _1
? PD + " Undefined Error : "+UPPER(Info)
CASE Logerror = 5 && Open_Error Model, _1
? PD + " Open Error : "+UPPER(Info)
CASE Logerror = 6 && Print_Error Model, _1
? PD + " Print Error : "+UPPER(Info)
ENDCASE
? PD + " Module : "+UPPER(Name)
? PD + " Line Number : "+LTRIM(TRANSFORM(Line,"999,999"))
IF !EMPTY(Model)
? PD + " Model : "+Model
ENDIF
IF Info = "type mismatch"
? PD + " Sample : "
?? Sample
ELSE
IF !EMPTY(_1)
? PD + " _1 : "
?? _1
? PD + " Type(_1) : "+TYPE("&_1.")
ENDIF
IF !EMPTY(_2)
? PD + " _2 : "
?? _2
? PD + " Type(_2) : "+TYPE("&_2.")
ENDIF
IF !EMPTY(_3)
? PD + " _3 : "
?? _3
? PD + " Type(_3) : "+TYPE("&_3.")
ENDIF
IF !EMPTY(_4)
? PD + " _4 : "
?? _4
? PD + " Type(_4) : "+TYPE("&_4.")
ENDIF
IF !EMPTY(_5)
? PD + " _5 : "
?? _5
? PD + " Type(_5) : "+TYPE("&_5.")
ENDIF
ENDIF
ENDIF
?
RETURN(.T.)


  3 Responses to “Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive   : ERRLOG2.ZIP
Filename : ERRORLOG.PRG

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/