CD Actual 15/CDACTUAL15.iso/cdactual/program/basic/QBLIST10.ZIP/QBLIST.BAS

BASIC Source File | 1992-10-25 | 15.1 KB | 706 lines

DECLARE SUB DataStmtLine ()
DECLARE SUB PressAKey ()
DECLARE SUB ListFunc ()
DECLARE SUB ListSubs ()
DECLARE SUB FunctionList ()
DECLARE SUB WriteLine ()
DECLARE SUB SplitLine ()
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$
COMMON SHARED Line1$, Line2$, Line3$, Line4$, LineLen

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
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
 CASE ELSE
  PRINT "ERROR CODE = "; ErrorCode
  PRINT "ErrorHandler Not Setup For This Error"
  INPUT "Please Press Any Key To Continue"; A$
  CALL EojRoutine
END SELECT

END

SUB CompleteList

START$ = "Y"

DO
 LINE INPUT #1, Line$
 LinesRead = LinesRead + 1
  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 DataStmtLine

CommaPos = 0
LastComma = 0
SaveLastComma = 0
Line1$ = ""
Line2$ = ""
Line3$ = ""
Line4$ = ""

DO
  LastComma = INSTR(LastComma + 1, Line$, ",")
  IF LastComma <> 0 THEN SaveLastComma = LastComma
  IF LastComma <= 80 AND LastComma <> 0 THEN CommaPos = SaveLastComma
LOOP UNTIL LastComma = 0
Line1$ = LEFT$(Line$, CommaPos)

IF LineLen > 80 AND LineLen <= 160 THEN
   Line2$ = MID$(Line$, CommaPos + 1, LineLen - CommaPos)
   EXIT SUB
END IF
LastComma = 0
Temp$ = MID$(Line$, CommaPos + 1, LineLen - CommaPos)
DO
  LastComma = INSTR(LastComma + 1, Temp$, ",")
  IF LastComma <> 0 THEN SaveLastComma = LastComma
  IF LastComma <= 80 AND LastComma <> 0 THEN CommaPos = SaveLastComma
LOOP UNTIL LastComma = 0
Line2$ = LEFT$(Temp$, CommaPos)
LastComma = 0

IF LineLen > 160 AND LineLen <= 240 THEN
   Line3$ = MID$(Temp$, CommaPos + 1, LineLen - CommaPos)
   EXIT SUB
END IF
LastComma = 0
Temp$ = MID$(Temp$, CommaPos + 1, LineLen - CommaPos)
DO
  LastComma = INSTR(LastComma + 1, Temp$, ",")
  IF LastComma <> 0 THEN SaveLastComma = LastComma
  IF LastComma <= 80 AND LastComma <> 0 THEN CommaPos = SaveLastComma
LOOP UNTIL LastComma = 0
Line3$ = LEFT$(Temp$, CommaPos)
LastComma = 0

IF LineLen > 240 AND LineLen <= 255 THEN
   Line4$ = MID$(Temp$, CommaPos + 1, LineLen - LastComma)
   EXIT SUB
END IF
LastComma = 0
Temp$ = MID$(Temp$, CommaPos + 1, LineLen - CommaPos)
DO
  LastComma = INSTR(LastComma + 1, Temp$, ",")
  IF LastComma <> 0 THEN SaveLastComma = LastComma
  IF LastComma <= 80 AND LastComma <> 0 THEN CommaPos = SaveLastComma
LOOP UNTIL LastComma = 0
Line4$ = LEFT$(Temp$, CommaPos)

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 SPC(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 SPC(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 PressAKey
  GOSUB FuncHeading
  X = 1
END IF
RETURN

FuncHeading:
  CALL ScreenTitle
  PRINT SPC(31); "List Of Functions"
  PRINT SPC(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 SPC(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 PressAKey
  GOSUB SubHeading
  X = 1
END IF
RETURN

SubHeading:
  CALL ScreenTitle
  PRINT SPC(30); "List Of SubRoutines"
  PRINT SPC(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, SPC(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 SPC(22); "(1) Complete": PRINT ""
PRINT SPC(22); "(2) Main Moudule": PRINT
PRINT SPC(22); "(3) SubRoutine": PRINT
PRINT SPC(22); "(4) Function": PRINT
PRINT SPC(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 PressAKey

LOCATE 20, 12, 0
PRINT "===> Please Press Any Key To Continue <==="
SOUND 1000, 2
CALL WaitforAnswer(A$)

END SUB

SUB ProgramTitle

PRINT #2, CHR$(12)
PRINT #2, SPC(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 SPC(22); "Qbasic Or QuickBasic Program Lister"
PRINT SPC(22); "-----------------------------------"

END SUB

SUB SplitLine

BlankPos = 0
LastBlank = 0
SaveLastBlank = 0
Line1$ = ""
Line2$ = ""
Line3$ = ""
Line4$ = ""

DO
  LastBlank = INSTR(LastBlank + 1, Line$, " ")
  IF LastBlank <> 0 THEN SaveLastBlank = LastBlank
  IF LastBlank <= 80 AND LastBlank <> 0 THEN BlankPos = SaveLastBlank
LOOP UNTIL LastBlank = 0
Line1$ = LEFT$(Line$, BlankPos)

IF LineLen > 80 AND LineLen <= 160 THEN
   Line2$ = MID$(Line$, BlankPos + 1, LineLen - BlankPos)
   EXIT SUB
END IF
LastBlank = 0
Temp$ = MID$(Line$, BlankPos + 1, LineLen - BlankPos)
DO
  LastBlank = INSTR(LastBlank + 1, Temp$, " ")
  IF LastBlank <> 0 THEN SaveLastBlank = LastBlank
  IF LastBlank <= 80 AND LastBlank <> 0 THEN BlankPos = SaveLastBlank
LOOP UNTIL LastBlank = 0
Line2$ = LEFT$(Temp$, BlankPos)
LastBlank = 0

IF LineLen > 160 AND LineLen <= 240 THEN
   Line3$ = MID$(Temp$, BlankPos + 1, LineLen - BlankPos)
   EXIT SUB
END IF
LastBlank = 0
Temp$ = MID$(Temp$, BlankPos + 1, LineLen - BlankPos)
DO
  LastBlank = INSTR(LastBlank + 1, Temp$, " ")
  IF LastBlank <> 0 THEN SaveLastBlank = LastBlank
  IF LastBlank <= 80 AND LastBlank <> 0 THEN BlankPos = SaveLastBlank
LOOP UNTIL LastBlank = 0
Line3$ = LEFT$(Temp$, BlankPos)
LastBlank = 0

IF LineLen > 240 AND LineLen <= 255 THEN
   Line4$ = MID$(Temp$, BlankPos + 1, LineLen - LastBlank)
   EXIT SUB
END IF
LastBlank = 0
Temp$ = MID$(Temp$, BlankPos + 1, LineLen - BlankPos)
DO
  LastBlank = INSTR(LastBlank + 1, Temp$, " ")
  IF LastBlank <> 0 THEN SaveLastBlank = LastBlank
  IF LastBlank <= 80 AND LastBlank <> 0 THEN BlankPos = SaveLastBlank
LOOP UNTIL LastBlank = 0
Line4$ = LEFT$(Temp$, BlankPos)

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 SPC(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, SPC(29); SubName$; " ("; SubType$; ")";
PRINT #2, " Page "; USING "###"; SubPageCount
PRINT #2, SPC(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

LineLen = LEN(Line$)

DataWord = INSTR(1, Line$, "DATA ")
IF DataWord <> 0 AND LineLen > 80 THEN
   CALL DataStmtLine
   GOTO Skip
END IF

IF LineLen <= 80 THEN
   PRINT #2, SPC(10); Line$
   LineCount = LineCount + 1
   GOSUB HeadRtn:
   EXIT SUB
END IF

IF LineLen > 80 THEN
   CALL SplitLine
Skip:
   PRINT #2, SPC(10); Line1$
   LineCount = LineCount + 1
   GOSUB HeadRtn
   PRINT #2, SPC(4); "<<*>> ";
   PRINT #2, Line2$
   LineCount = LineCount + 1
   GOSUB HeadRtn
   IF Line3$ = "" THEN EXIT SUB
   PRINT #2, SPC(4); "<<*>> ";
   PRINT #2, Line3$
   LineCount = LineCount + 1
   GOSUB HeadRtn
   IF Line4$ = "" THEN EXIT SUB
   PRINT #2, SPC(4); "<<*>> ";
   PRINT #2, Line4$
   LOCATE 17, 1
   LineCount = LineCount + 1
   GOSUB HeadRtn
END IF
EXIT SUB

HeadRtn:
   IF LineCount = 82 THEN
   CALL ProgramTitle
   CALL SubTitle
END IF
RETURN

END SUB