home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Black Box 4
/
BlackBox.cdr
/
progbas
/
qblist.arj
/
QBLIST.BAS
next >
Wrap
BASIC Source File
|
1992-01-20
|
12KB
|
563 lines
DECLARE SUB ListFunc ()
DECLARE FUNCTION test! ()
DECLARE SUB ListSubs ()
DECLARE SUB FunctionList ()
DECLARE SUB WriteLine ()
DECLARE SUB SplitLine ()
DECLARE FUNCTION TEST1$ ()
DECLARE FUNCTION TEST2% ()
DECLARE FUNCTION TESTA! ()
DECLARE SUB MainRoutine ()
DECLARE SUB EojRoutine ()
DECLARE SUB EndOfList ()
DECLARE SUB MainModuleList ()
DECLARE SUB SubRoutineList ()
DECLARE SUB CompleteList ()
DECLARE SUB WaitforAnswer (A$)
DECLARE SUB ScreenTitle ()
DECLARE SUB SubTitle ()
DECLARE SUB MainModule ()
DECLARE SUB ProgramTitle ()
DECLARE SUB OpenFiles ()
COMMON SHARED Line$, FileName$, SubName$, Today$, TheTime$, FullPageCount
COMMON SHARED subPageCount, LineCount, SubRoutineType, SubType$, Line1$, Line2$
REM **********************************
REM * Set Printer To 12 CPI at 8 LPI *
REM **********************************
ON ERROR GOTO ErrorHandler
Today$ = DATE$
TheTime$ = TIME$
Redo:
CALL MainRoutine
ErrorHandler:
SOUND 1000, 2
PRINT
ErrorCode = ERR
PRINT "ERROR CODE = "; ErrorCode
SELECT CASE ErrorCode
CASE 64
PRINT "Bad File Name ==> "; FileName$; " <=="
INPUT "Please Press Any Key To Continue"; A$
RESUME Redo
CASE 53
PRINT "File Not Found ==> "; FileName$; " <=="
INPUT "Please Press Any Key To Continue"; A$
RESUME Redo
END SELECT
END
SUB CompleteList
START$ = "Y"
DO
LINE INPUT #1, Line$
IF LEFT$(Line$, 4) = "SUB " THEN
NamePosition = 5
GOSUB GetSubName
CALL ProgramTitle
subPageCount = 1
SubRoutineType = 2
CALL SubTitle
START$ = "N"
ELSEIF LEFT$(Line$, 8) = "FUNCTION" THEN
NamePosition = 10
GOSUB GetSubName
CALL ProgramTitle
subPageCount = 1
SubRoutineType = 3
CALL SubTitle
START$ = "N"
ELSEIF (LEFT$(Line$, 4) <> "SUB " OR LEFT$(Line$, 8) <> "FUNCTION") AND START$ = "Y" THEN
subPageCount = 1
CALL ProgramTitle
SubName$ = FileName$
SubRoutineType = 1
CALL SubTitle
START$ = "N"
END IF
START$ = "N"
CALL WriteLine
LOOP WHILE NOT EOF(1)
PRINT #2, CHR$(12)
CLOSE #1, #2
CALL EndOfList
CALL MainRoutine
GetSubName:
SpacePos = INSTR(NamePosition, Line$, " ")
IF SpacePos = 0 THEN
SpacePos = LEN(Line$)
SpacePos = SpacePos - (NamePosition - 1)
SubName$ = MID$(Line$, NamePosition, SpacePos)
ELSEIF SpacePos > 0 AND NamePosition = 5 THEN
SpacePos = SpacePos - 4
SubName$ = MID$(Line$, 5, SpacePos - 1)
ELSEIF SpacePos > 0 AND NamePosition = 10 THEN
SpacePos = SpacePos - 9
SubName$ = MID$(Line$, 10, SpacePos - 1)
END IF
RETURN
END SUB
SUB EndOfList
LOCATE 20, 12, 0
PRINT "===> End Of List, Please Press Any Key To Continue <==="
SOUND 1000, 2
CALL WaitforAnswer(A$)
END SUB
SUB EojRoutine
CLOSE #1, #2
CLS
SYSTEM
END SUB
SUB FunctionList
StartFunc:
CALL ScreenTitle
DO
LOCATE 6, 1
PRINT "Please Enter Function To List"
PRINT "(L)ist To List Functions"
INPUT "Or (Q)uit to End ==> "; FuncTofind$
LOOP WHILE FuncTofind$ = ""
IF UCASE$(FuncTofind$) = "QUIT" OR UCASE$(FuncTofind$) = "Q" THEN
CALL EndOfList
CALL MainRoutine
END IF
IF UCASE$(FuncTofind$) = "LIST" OR UCASE$(FuncTofind$) = "L" THEN
CALL ListFunc
CALL EndOfList
CALL MainRoutine
END IF
LineCount = 4
FoundFunc$ = "N"
FindFunc:
DO
LINE INPUT #1, Line$
IF LEFT$(Line$, 8) = "FUNCTION" THEN GOSUB FoundFunc
LOOP UNTIL EOF(1) OR FoundFunc$ = "Y"
IF FoundFunc$ = "Y" THEN
PRINT #2, CHR$(12)
CLOSE #1, #2
CALL EndOfList
CALL MainRoutine
END IF
IF FoundFunc$ = "N" THEN
PRINT TAB(10); "===> FUNCTION "; UCASE$(FuncTofind$); " Not Found <==="
SOUND 1000, 2
PRINT "Please Press Any Key To Continue"
CALL WaitforAnswer(A$)
CLOSE #1, #2
CALL OpenFiles
GOTO StartFunc
END IF
FoundFunc:
SpacePos = INSTR(10, Line$, " ")
IF SpacePos = 0 THEN
SpacePos = LEN(Line$)
SpacePos = SpacePos - 9
FuncName$ = MID$(Line$, 10, SpacePos)
ELSEIF SpacePos > 0 THEN
SpacePos = SpacePos - 9
FuncName$ = MID$(Line$, 10, SpacePos - 1)
END IF
IF UCASE$(FuncName$) = UCASE$(FuncTofind$) THEN
CALL ProgramTitle
SubRoutineType = 3
SubName$ = FuncName$
CALL SubTitle
FoundFunc$ = "Y"
GOSUB PrintFunc
END IF
RETURN
PrintFunc:
DO
CALL WriteLine
LINE INPUT #1, Line$
LOOP UNTIL LEFT$(Line$, 4) = "SUB " OR LEFT$(Line$, 8) = "FUNCTION" OR EOF(1)
RETURN
END SUB
SUB ListFunc
X = 1
GOSUB FuncHeading
FuncFound$ = "N"
DO
LINE INPUT #1, Line$
IF LEFT$(Line$, 8) = "FUNCTION" THEN
GOSUB ListFunc
FuncFound$ = "Y"
END IF
LOOP WHILE NOT EOF(1)
IF FuncFound$ = "N" THEN PRINT TAB(31); "No Functions Found"
CALL EndOfList
CLOSE #1
OPEN FileName$ FOR INPUT AS #1
CALL FunctionList
ListFunc:
SpacePos = INSTR(10, Line$, " ")
IF SpacePos = 0 THEN
SpacePos = LEN(Line$)
SpacePos = SpacePos - 9
FuncName$ = MID$(Line$, 10, SpacePos)
ELSEIF SpacePos > 0 THEN
SpacePos = SpacePos - 9
FuncName$ = MID$(Line$, 10, SpacePos - 1)
END IF
PRINT FuncName$
X = X + 1
IF X > 10 THEN
CALL EndOfList
GOSUB FuncHeading
X = 1
END IF
RETURN
FuncHeading:
CALL ScreenTitle
PRINT TAB(31); "List Of Functions"
PRINT TAB(31); "-----------------"
RETURN
END SUB
SUB ListSubs
X = 1
GOSUB SubHeading
SubFound$ = "N"
DO
LINE INPUT #1, Line$
IF LEFT$(Line$, 4) = "SUB " THEN
GOSUB ListSub
SubFound$ = "Y"
END IF
LOOP WHILE NOT EOF(1)
IF SubFound$ = "N" THEN PRINT TAB(30); "No SubRoutines Found"
CALL EndOfList
CLOSE #1
OPEN FileName$ FOR INPUT AS #1
CALL SubRoutineList
ListSub:
SpacePos = INSTR(5, Line$, " ")
IF SpacePos = 0 THEN
SpacePos = LEN(Line$)
SpacePos = SpacePos - 4
SubName$ = MID$(Line$, 5, SpacePos)
ELSEIF SpacePos > 0 THEN
SpacePos = SpacePos - 4
SubName$ = MID$(Line$, 5, SpacePos - 1)
END IF
PRINT SubName$
X = X + 1
IF X > 10 THEN
CALL EndOfList
GOSUB SubHeading
X = 1
END IF
RETURN
SubHeading:
CALL ScreenTitle
PRINT TAB(30); "List Of SubRoutines"
PRINT TAB(30); "-------------------"
RETURN
END SUB
SUB MainModuleList
LineCount = 4
START$ = "Y"
SubName$ = FileName$
CALL ProgramTitle
SubRoutineType = 1
CALL SubTitle
DO
LINE INPUT #1, Line$
IF LEFT$(Line$, 4) = "SUB " AND (START$ = "Y" OR START$ = "N") THEN
IF LEFT$(Line$, 8) = "FUNCTION" AND (START$ = "Y" OR START$ = "N") THEN
PRINT #2, TAB(10); "No Main Module"
CLOSE #1
CALL EndOfList
CALL MainRoutine
END IF
END IF
START$ = "N"
IF LEFT$(Line$, 4) = "SUB " OR LEFT$(Line$, 8) = "FUNCTION" THEN EXIT DO
CALL WriteLine
LOOP WHILE NOT EOF(1)
PRINT #2, CHR$(12)
CLOSE #1, #2
CALL EndOfList
CALL MainRoutine
END SUB
SUB MainRoutine
FullPageCount = 1
subPageCount = 1
LineCount = 4
CALL ScreenTitle
DO
LOCATE 6, 1
PRINT "Please Enter Program To List"
INPUT "Or (Q)uit To End ==> "; FileName$
LOOP WHILE FileName$ = ""
IF UCASE$(FileName$) = "QUIT" OR UCASE$(FileName$) = "Q" THEN CALL EojRoutine
FileName$ = UCASE$(FileName$ + ".BAS")
CALL OpenFiles
DO
CALL ScreenTitle
PRINT TAB(22); "(1) Complete": PRINT ""
PRINT TAB(22); "(2) Main Moudule": PRINT
PRINT TAB(22); "(3) SubRoutine": PRINT
PRINT TAB(22); "(4) Function": PRINT
PRINT TAB(22); "(5) Quit"
Retry:
LOCATE 16, 1
PRINT "Please Enter Type Of Listing You Want ==> "
LOCATE 16, 43, 1
CALL WaitforAnswer(A$)
Answer = VAL(A$)
LOCATE 16, 43, 1
PRINT A$
SELECT CASE Answer
CASE IS = 1
LOCATE 17, 1
PRINT " "
CALL CompleteList
CALL EndOfList
CASE IS = 2
LOCATE 17, 1
PRINT " "
CALL MainModuleList
CALL EndOfList
CASE IS = 3
CALL SubRoutineList
CALL EndOfList
CASE IS = 4
CALL FunctionList
CALL EndOfList
CASE IS = 5
CALL EojRoutine
CASE ELSE
LOCATE 17, 1
SOUND 1000, 2
PRINT "==> Invalid Selection <=="
GOTO Retry
END SELECT
LOOP
END SUB
SUB OpenFiles
OPEN FileName$ FOR INPUT AS #1
DotPos = INSTR(FileName$, ".")
OutName$ = LEFT$(FileName$, DotPos - 1)
OutName$ = OutName$ + ".LST"
OPEN OutName$ FOR OUTPUT AS #2
END SUB
SUB ProgramTitle
PRINT #2, CHR$(12)
PRINT #2, TAB(10); "Program Listing Of "; FileName$;
PRINT #2, " As Of "; Today$; " At "; TheTime$;
PRINT #2, " Page "; USING "###"; FullPageCount
FullPageCount = FullPageCount + 1
END SUB
SUB ScreenTitle
CLS
COLOR 15, 1
PRINT "DATE = "; DATE$;
LOCATE 1, 66
PRINT "TIME = "; TIME$
PRINT
PRINT TAB(22); "Qbasic Or QuickBasic Program Lister"
PRINT TAB(22); "-----------------------------------"
END SUB
SUB SplitLine
LineLen = LEN(Line$)
LinePos = 0
LastBlank = 1
DO WHILE LastBlank <> 0
IF LastBlank <> 0 THEN SaveLastBlank = LastBlank
LastBlank = INSTR(LastBlank + 1, Line$, " ")
IF LastBlank >= 80 THEN EXIT DO ELSE LinePos = LastBlank
LOOP
IF LastBlank = 0 THEN LinePos = SaveLastBlank
IF SaveLastBlank = 4 THEN LinePos = 80
Line1$ = MID$(Line$, 1, LinePos - 1)
Line2$ = MID$(Line$, LinePos + 1, LineLen)
END SUB
SUB SubRoutineList
StartSub:
CALL ScreenTitle
DO
LOCATE 6, 1
PRINT "Please Enter SubRoutine To List"
PRINT "(L)ist To List SubRoutines"
INPUT "Or (Q)uit to End ==> "; SubToFind$
LOOP WHILE SubToFind$ = ""
IF UCASE$(SubToFind$) = "QUIT" OR UCASE$(SubToFind$) = "Q" THEN
CLOSE #1, #2
CALL EndOfList
CALL MainRoutine
END IF
IF UCASE$(SubToFind$) = "LIST" OR UCASE$(SubToFind$) = "L" THEN
CALL ListSubs
END IF
LineCount = 4
FoundSub$ = "N"
FindSub:
DO
LINE INPUT #1, Line$
IF LEFT$(Line$, 4) = "SUB " THEN GOSUB FoundSub
LOOP UNTIL EOF(1) OR FoundSub$ = "Y"
IF FoundSub$ = "Y" THEN
PRINT #2, CHR$(12)
CLOSE #1, #2
CALL EndOfList
CALL MainRoutine
END IF
IF FoundSub$ = "N" THEN
PRINT TAB(10); "===> Sub Routine "; UCASE$(SubToFind$); " Not Found <==="
SOUND 1000, 2
PRINT "Please Press Any Key To Continue"
CALL WaitforAnswer(A$)
CLOSE #1, #2
CALL OpenFiles
GOTO StartSub
END IF
FoundSub:
SpacePos = INSTR(5, Line$, " ")
IF SpacePos = 0 THEN
SpacePos = LEN(Line$)
SpacePos = SpacePos - 4
SubName$ = MID$(Line$, 5, SpacePos)
ELSEIF SpacePos > 0 THEN
SpacePos = SpacePos - 4
SubName$ = MID$(Line$, 5, SpacePos - 1)
END IF
IF UCASE$(SubName$) = UCASE$(SubToFind$) THEN
CALL ProgramTitle
SubRoutineType = 2
CALL SubTitle
FoundSub$ = "Y"
GOSUB PrintSub
END IF
RETURN
PrintSub:
DO
CALL WriteLine
LINE INPUT #1, Line$
LOOP UNTIL LEFT$(Line$, 4) = "SUB " OR LEFT$(Line$, 8) = "FUNCTION" OR EOF(1)
RETURN
END SUB
SUB SubTitle
IF SubRoutineType = 1 THEN SubType$ = "Main Module"
IF SubRoutineType = 2 THEN SubType$ = "Sub Routine"
IF SubRoutineType = 3 THEN SubType$ = "Function"
PRINT #2, TAB(29); SubName$; " ("; SubType$; ")";
PRINT #2, " Page "; USING "###"; subPageCount
PRINT #2, TAB(10); STRING$(80, 45)
PRINT #2,
subPageCount = subPageCount + 1
LineCount = 4
END SUB
SUB WaitforAnswer (A$)
Answer$ = ""
A$ = ""
DO
A$ = UCASE$(INKEY$)
LOOP WHILE A$ = ""
END SUB
SUB WriteLine
IF LEN(Line$) > 80 THEN
CALL SplitLine
PRINT #2, TAB(10); Line1$
PRINT #2, TAB(4); "<<*>> ";
PRINT #2, Line2$
LineCount = LineCount + 2
END IF
IF LEN(Line$) <= 80 THEN
PRINT #2, TAB(10); Line$
LineCount = LineCount + 1
END IF
IF LineCount = 82 THEN
CALL ProgramTitle
CALL SubTitle
END IF
END SUB