home *** CD-ROM | disk | FTP | other *** search
/ World of Shareware - Software Farm 2 / wosw_2.zip / wosw_2 / QBAS / QBLIST.ZIP / QBLIST.BAS next >
BASIC Source File  |  1992-01-20  |  12KB  |  563 lines
  1. DECLARE SUB ListFunc ()
  2. DECLARE FUNCTION test! ()
  3. DECLARE SUB ListSubs ()
  4. DECLARE SUB FunctionList ()
  5. DECLARE SUB WriteLine ()
  6. DECLARE SUB SplitLine ()
  7. DECLARE FUNCTION TEST1$ ()
  8. DECLARE FUNCTION TEST2% ()
  9. DECLARE FUNCTION TESTA! ()
  10. DECLARE SUB MainRoutine ()
  11. DECLARE SUB EojRoutine ()
  12. DECLARE SUB EndOfList ()
  13. DECLARE SUB MainModuleList ()
  14. DECLARE SUB SubRoutineList ()
  15. DECLARE SUB CompleteList ()
  16. DECLARE SUB WaitforAnswer (A$)
  17. DECLARE SUB ScreenTitle ()
  18. DECLARE SUB SubTitle ()
  19. DECLARE SUB MainModule ()
  20. DECLARE SUB ProgramTitle ()
  21. DECLARE SUB OpenFiles ()
  22.  
  23. COMMON SHARED Line$, FileName$, SubName$, Today$, TheTime$, FullPageCount
  24. COMMON SHARED subPageCount, LineCount, SubRoutineType, SubType$, Line1$, Line2$
  25.  
  26.  
  27. REM **********************************
  28. REM * Set Printer To 12 CPI at 8 LPI *
  29. REM **********************************
  30.  
  31. ON ERROR GOTO ErrorHandler
  32.  
  33. Today$ = DATE$
  34. TheTime$ = TIME$
  35.  
  36. Redo:
  37.  
  38. CALL MainRoutine
  39.  
  40. ErrorHandler:
  41. SOUND 1000, 2
  42. PRINT
  43. ErrorCode = ERR
  44. PRINT "ERROR CODE = "; ErrorCode
  45. SELECT CASE ErrorCode
  46.  CASE 64
  47.   PRINT "Bad File Name ==> "; FileName$; " <=="
  48.   INPUT "Please Press Any Key To Continue"; A$
  49.   RESUME Redo
  50.  CASE 53
  51.   PRINT "File Not Found ==> "; FileName$; " <=="
  52.   INPUT "Please Press Any Key To Continue"; A$
  53.   RESUME Redo
  54. END SELECT
  55.  
  56. END
  57.  
  58. SUB CompleteList
  59.  
  60. START$ = "Y"
  61.  
  62. DO
  63.  LINE INPUT #1, Line$
  64.   IF LEFT$(Line$, 4) = "SUB " THEN
  65.     NamePosition = 5
  66.     GOSUB GetSubName
  67.     CALL ProgramTitle
  68.     subPageCount = 1
  69.     SubRoutineType = 2
  70.     CALL SubTitle
  71.     START$ = "N"
  72.   ELSEIF LEFT$(Line$, 8) = "FUNCTION" THEN
  73.     NamePosition = 10
  74.     GOSUB GetSubName
  75.     CALL ProgramTitle
  76.     subPageCount = 1
  77.     SubRoutineType = 3
  78.     CALL SubTitle
  79.     START$ = "N"
  80.   ELSEIF (LEFT$(Line$, 4) <> "SUB " OR LEFT$(Line$, 8) <> "FUNCTION") AND START$ = "Y" THEN
  81.      subPageCount = 1
  82.      CALL ProgramTitle
  83.      SubName$ = FileName$
  84.      SubRoutineType = 1
  85.      CALL SubTitle
  86.      START$ = "N"
  87.   END IF
  88. START$ = "N"
  89. CALL WriteLine
  90. LOOP WHILE NOT EOF(1)
  91.  
  92. PRINT #2, CHR$(12)
  93. CLOSE #1, #2
  94. CALL EndOfList
  95. CALL MainRoutine
  96.  
  97. GetSubName:
  98.   
  99. SpacePos = INSTR(NamePosition, Line$, " ")
  100.  IF SpacePos = 0 THEN
  101.     SpacePos = LEN(Line$)
  102.     SpacePos = SpacePos - (NamePosition - 1)
  103.     SubName$ = MID$(Line$, NamePosition, SpacePos)
  104.  ELSEIF SpacePos > 0 AND NamePosition = 5 THEN
  105.     SpacePos = SpacePos - 4
  106.     SubName$ = MID$(Line$, 5, SpacePos - 1)
  107.  ELSEIF SpacePos > 0 AND NamePosition = 10 THEN
  108.     SpacePos = SpacePos - 9
  109.     SubName$ = MID$(Line$, 10, SpacePos - 1)
  110.  END IF
  111. RETURN
  112.  
  113. END SUB
  114.  
  115. SUB EndOfList
  116.  
  117. LOCATE 20, 12, 0
  118. PRINT "===> End Of List, Please Press Any Key To Continue <==="
  119. SOUND 1000, 2
  120. CALL WaitforAnswer(A$)
  121.  
  122. END SUB
  123.  
  124. SUB EojRoutine
  125.  
  126. CLOSE #1, #2
  127. CLS
  128. SYSTEM
  129.  
  130. END SUB
  131.  
  132. SUB FunctionList
  133.  
  134. StartFunc:
  135. CALL ScreenTitle
  136. DO
  137. LOCATE 6, 1
  138. PRINT "Please Enter Function To List"
  139. PRINT "(L)ist To List Functions"
  140. INPUT "Or (Q)uit to End ==> "; FuncTofind$
  141. LOOP WHILE FuncTofind$ = ""
  142. IF UCASE$(FuncTofind$) = "QUIT" OR UCASE$(FuncTofind$) = "Q" THEN
  143.  CALL EndOfList
  144.  CALL MainRoutine
  145. END IF
  146. IF UCASE$(FuncTofind$) = "LIST" OR UCASE$(FuncTofind$) = "L" THEN
  147.  CALL ListFunc
  148.  CALL EndOfList
  149.  CALL MainRoutine
  150. END IF
  151.  
  152. LineCount = 4
  153. FoundFunc$ = "N"
  154.  
  155. FindFunc:
  156. DO
  157.    LINE INPUT #1, Line$
  158.    IF LEFT$(Line$, 8) = "FUNCTION" THEN GOSUB FoundFunc
  159. LOOP UNTIL EOF(1) OR FoundFunc$ = "Y"
  160.  
  161. IF FoundFunc$ = "Y" THEN
  162.   PRINT #2, CHR$(12)
  163.   CLOSE #1, #2
  164.   CALL EndOfList
  165.   CALL MainRoutine
  166. END IF
  167.  
  168. IF FoundFunc$ = "N" THEN
  169.   PRINT TAB(10); "===> FUNCTION "; UCASE$(FuncTofind$); " Not Found <==="
  170.   SOUND 1000, 2
  171.   PRINT "Please Press Any Key To Continue"
  172.   CALL WaitforAnswer(A$)
  173.   CLOSE #1, #2
  174.   CALL OpenFiles
  175.   GOTO StartFunc
  176. END IF
  177.  
  178. FoundFunc:
  179.   SpacePos = INSTR(10, Line$, " ")
  180.   IF SpacePos = 0 THEN
  181.      SpacePos = LEN(Line$)
  182.      SpacePos = SpacePos - 9
  183.      FuncName$ = MID$(Line$, 10, SpacePos)
  184.   ELSEIF SpacePos > 0 THEN
  185.      SpacePos = SpacePos - 9
  186.      FuncName$ = MID$(Line$, 10, SpacePos - 1)
  187.   END IF
  188.   IF UCASE$(FuncName$) = UCASE$(FuncTofind$) THEN
  189.     CALL ProgramTitle
  190.     SubRoutineType = 3
  191.     SubName$ = FuncName$
  192.     CALL SubTitle
  193.     FoundFunc$ = "Y"
  194.     GOSUB PrintFunc
  195.   END IF
  196. RETURN
  197.  
  198. PrintFunc:
  199.   DO
  200.     CALL WriteLine
  201.     LINE INPUT #1, Line$
  202.   LOOP UNTIL LEFT$(Line$, 4) = "SUB " OR LEFT$(Line$, 8) = "FUNCTION" OR EOF(1)
  203. RETURN
  204.  
  205. END SUB
  206.  
  207. SUB ListFunc
  208.  
  209. X = 1
  210. GOSUB FuncHeading
  211. FuncFound$ = "N"
  212.  
  213. DO
  214.   LINE INPUT #1, Line$
  215.   IF LEFT$(Line$, 8) = "FUNCTION" THEN
  216.     GOSUB ListFunc
  217.     FuncFound$ = "Y"
  218.   END IF
  219. LOOP WHILE NOT EOF(1)
  220.  
  221. IF FuncFound$ = "N" THEN PRINT TAB(31); "No Functions Found"
  222. CALL EndOfList
  223. CLOSE #1
  224. OPEN FileName$ FOR INPUT AS #1
  225. CALL FunctionList
  226.  
  227. ListFunc:
  228.   SpacePos = INSTR(10, Line$, " ")
  229.   IF SpacePos = 0 THEN
  230.      SpacePos = LEN(Line$)
  231.      SpacePos = SpacePos - 9
  232.      FuncName$ = MID$(Line$, 10, SpacePos)
  233.   ELSEIF SpacePos > 0 THEN
  234.          SpacePos = SpacePos - 9
  235.          FuncName$ = MID$(Line$, 10, SpacePos - 1)
  236.   END IF
  237. PRINT FuncName$
  238. X = X + 1
  239. IF X > 10 THEN
  240.   CALL EndOfList
  241.   GOSUB FuncHeading
  242.   X = 1
  243. END IF
  244. RETURN
  245.  
  246. FuncHeading:
  247.   CALL ScreenTitle
  248.   PRINT TAB(31); "List Of Functions"
  249.   PRINT TAB(31); "-----------------"
  250. RETURN
  251.  
  252. END SUB
  253.  
  254. SUB ListSubs
  255.  
  256. X = 1
  257. GOSUB SubHeading
  258. SubFound$ = "N"
  259.  
  260. DO
  261.   LINE INPUT #1, Line$
  262.   IF LEFT$(Line$, 4) = "SUB " THEN
  263.     GOSUB ListSub
  264.     SubFound$ = "Y"
  265.   END IF
  266. LOOP WHILE NOT EOF(1)
  267.  
  268. IF SubFound$ = "N" THEN PRINT TAB(30); "No SubRoutines Found"
  269. CALL EndOfList
  270. CLOSE #1
  271. OPEN FileName$ FOR INPUT AS #1
  272. CALL SubRoutineList
  273.  
  274. ListSub:
  275.   SpacePos = INSTR(5, Line$, " ")
  276.   IF SpacePos = 0 THEN
  277.      SpacePos = LEN(Line$)
  278.      SpacePos = SpacePos - 4
  279.      SubName$ = MID$(Line$, 5, SpacePos)
  280.   ELSEIF SpacePos > 0 THEN
  281.          SpacePos = SpacePos - 4
  282.          SubName$ = MID$(Line$, 5, SpacePos - 1)
  283.   END IF
  284. PRINT SubName$
  285. X = X + 1
  286. IF X > 10 THEN
  287.   CALL EndOfList
  288.   GOSUB SubHeading
  289.   X = 1
  290. END IF
  291. RETURN
  292.  
  293. SubHeading:
  294.   CALL ScreenTitle
  295.   PRINT TAB(30); "List Of SubRoutines"
  296.   PRINT TAB(30); "-------------------"
  297. RETURN
  298.  
  299. END SUB
  300.  
  301. SUB MainModuleList
  302.  
  303. LineCount = 4
  304. START$ = "Y"
  305. SubName$ = FileName$
  306. CALL ProgramTitle
  307. SubRoutineType = 1
  308. CALL SubTitle
  309.  
  310. DO
  311.  LINE INPUT #1, Line$
  312.   IF LEFT$(Line$, 4) = "SUB " AND (START$ = "Y" OR START$ = "N") THEN
  313.     IF LEFT$(Line$, 8) = "FUNCTION" AND (START$ = "Y" OR START$ = "N") THEN
  314.       PRINT #2, TAB(10); "No Main Module"
  315.       CLOSE #1
  316.       CALL EndOfList
  317.       CALL MainRoutine
  318.     END IF
  319.   END IF
  320. START$ = "N"
  321. IF LEFT$(Line$, 4) = "SUB " OR LEFT$(Line$, 8) = "FUNCTION" THEN EXIT DO
  322.  CALL WriteLine
  323. LOOP WHILE NOT EOF(1)
  324.  
  325. PRINT #2, CHR$(12)
  326. CLOSE #1, #2
  327. CALL EndOfList
  328. CALL MainRoutine
  329.  
  330. END SUB
  331.  
  332. SUB MainRoutine
  333.  
  334. FullPageCount = 1
  335. subPageCount = 1
  336. LineCount = 4
  337.  
  338. CALL ScreenTitle
  339. DO
  340. LOCATE 6, 1
  341. PRINT "Please Enter Program To List"
  342. INPUT "Or (Q)uit To End ==> "; FileName$
  343. LOOP WHILE FileName$ = ""
  344. IF UCASE$(FileName$) = "QUIT" OR UCASE$(FileName$) = "Q" THEN CALL EojRoutine
  345. FileName$ = UCASE$(FileName$ + ".BAS")
  346.  
  347. CALL OpenFiles
  348.  
  349. DO
  350. CALL ScreenTitle
  351. PRINT TAB(22); "(1) Complete": PRINT ""
  352. PRINT TAB(22); "(2) Main Moudule": PRINT
  353. PRINT TAB(22); "(3) SubRoutine": PRINT
  354. PRINT TAB(22); "(4) Function": PRINT
  355. PRINT TAB(22); "(5) Quit"
  356. Retry:
  357. LOCATE 16, 1
  358. PRINT "Please Enter Type Of Listing You Want ==> "
  359. LOCATE 16, 43, 1
  360. CALL WaitforAnswer(A$)
  361. Answer = VAL(A$)
  362. LOCATE 16, 43, 1
  363. PRINT A$
  364. SELECT CASE Answer
  365.  CASE IS = 1
  366.    LOCATE 17, 1
  367.    PRINT "                          "
  368.    CALL CompleteList
  369.    CALL EndOfList
  370.  CASE IS = 2
  371.    LOCATE 17, 1
  372.    PRINT "                          "
  373.    CALL MainModuleList
  374.    CALL EndOfList
  375.  CASE IS = 3
  376.    CALL SubRoutineList
  377.    CALL EndOfList
  378.  CASE IS = 4
  379.    CALL FunctionList
  380.    CALL EndOfList
  381.  CASE IS = 5
  382.    CALL EojRoutine
  383.  CASE ELSE
  384.    LOCATE 17, 1
  385.    SOUND 1000, 2
  386.    PRINT "==> Invalid Selection <=="
  387.    GOTO Retry
  388. END SELECT
  389. LOOP
  390.  
  391. END SUB
  392.  
  393. SUB OpenFiles
  394.  
  395. OPEN FileName$ FOR INPUT AS #1
  396. DotPos = INSTR(FileName$, ".")
  397. OutName$ = LEFT$(FileName$, DotPos - 1)
  398. OutName$ = OutName$ + ".LST"
  399. OPEN OutName$ FOR OUTPUT AS #2
  400.  
  401. END SUB
  402.  
  403. SUB ProgramTitle
  404.  
  405. PRINT #2, CHR$(12)
  406. PRINT #2, TAB(10); "Program Listing Of "; FileName$;
  407. PRINT #2, " As Of "; Today$; " At "; TheTime$;
  408. PRINT #2, "            Page "; USING "###"; FullPageCount
  409. FullPageCount = FullPageCount + 1
  410.  
  411. END SUB
  412.  
  413. SUB ScreenTitle
  414.  
  415. CLS
  416. COLOR 15, 1
  417. PRINT "DATE = "; DATE$;
  418. LOCATE 1, 66
  419. PRINT "TIME = "; TIME$
  420. PRINT
  421. PRINT TAB(22); "Qbasic Or QuickBasic Program Lister"
  422. PRINT TAB(22); "-----------------------------------"
  423.  
  424. END SUB
  425.  
  426. SUB SplitLine
  427.  
  428. LineLen = LEN(Line$)
  429. LinePos = 0
  430. LastBlank = 1
  431.  
  432. DO WHILE LastBlank <> 0
  433. IF LastBlank <> 0 THEN SaveLastBlank = LastBlank
  434. LastBlank = INSTR(LastBlank + 1, Line$, " ")
  435. IF LastBlank >= 80 THEN EXIT DO ELSE LinePos = LastBlank
  436. LOOP
  437.  
  438. IF LastBlank = 0 THEN LinePos = SaveLastBlank
  439. IF SaveLastBlank = 4 THEN LinePos = 80
  440. Line1$ = MID$(Line$, 1, LinePos - 1)
  441. Line2$ = MID$(Line$, LinePos + 1, LineLen)
  442.  
  443. END SUB
  444.  
  445. SUB SubRoutineList
  446.  
  447. StartSub:
  448. CALL ScreenTitle
  449. DO
  450. LOCATE 6, 1
  451. PRINT "Please Enter SubRoutine To List"
  452. PRINT "(L)ist To List SubRoutines"
  453. INPUT "Or (Q)uit to End ==> "; SubToFind$
  454. LOOP WHILE SubToFind$ = ""
  455. IF UCASE$(SubToFind$) = "QUIT" OR UCASE$(SubToFind$) = "Q" THEN
  456.  CLOSE #1, #2
  457.  CALL EndOfList
  458.  CALL MainRoutine
  459. END IF
  460. IF UCASE$(SubToFind$) = "LIST" OR UCASE$(SubToFind$) = "L" THEN
  461.  CALL ListSubs
  462. END IF
  463.  
  464. LineCount = 4
  465. FoundSub$ = "N"
  466.  
  467. FindSub:
  468. DO
  469.    LINE INPUT #1, Line$
  470.    IF LEFT$(Line$, 4) = "SUB " THEN GOSUB FoundSub
  471. LOOP UNTIL EOF(1) OR FoundSub$ = "Y"
  472.  
  473. IF FoundSub$ = "Y" THEN
  474.   PRINT #2, CHR$(12)
  475.   CLOSE #1, #2
  476.   CALL EndOfList
  477.   CALL MainRoutine
  478. END IF
  479.  
  480. IF FoundSub$ = "N" THEN
  481.   PRINT TAB(10); "===> Sub Routine "; UCASE$(SubToFind$); " Not Found <==="
  482.   SOUND 1000, 2
  483.   PRINT "Please Press Any Key To Continue"
  484.   CALL WaitforAnswer(A$)
  485.   CLOSE #1, #2
  486.   CALL OpenFiles
  487.   GOTO StartSub
  488. END IF
  489.  
  490. FoundSub:
  491.   SpacePos = INSTR(5, Line$, " ")
  492.   IF SpacePos = 0 THEN
  493.      SpacePos = LEN(Line$)
  494.      SpacePos = SpacePos - 4
  495.      SubName$ = MID$(Line$, 5, SpacePos)
  496.   ELSEIF SpacePos > 0 THEN
  497.      SpacePos = SpacePos - 4
  498.      SubName$ = MID$(Line$, 5, SpacePos - 1)
  499.   END IF
  500.   IF UCASE$(SubName$) = UCASE$(SubToFind$) THEN
  501.     CALL ProgramTitle
  502.     SubRoutineType = 2
  503.     CALL SubTitle
  504.     FoundSub$ = "Y"
  505.     GOSUB PrintSub
  506.   END IF
  507. RETURN
  508.  
  509. PrintSub:
  510.   DO
  511.     CALL WriteLine
  512.     LINE INPUT #1, Line$
  513.   LOOP UNTIL LEFT$(Line$, 4) = "SUB " OR LEFT$(Line$, 8) = "FUNCTION" OR EOF(1)
  514. RETURN
  515.  
  516. END SUB
  517.  
  518. SUB SubTitle
  519.  
  520. IF SubRoutineType = 1 THEN SubType$ = "Main Module"
  521. IF SubRoutineType = 2 THEN SubType$ = "Sub Routine"
  522. IF SubRoutineType = 3 THEN SubType$ = "Function"
  523.  
  524. PRINT #2, TAB(29); SubName$; " ("; SubType$; ")";
  525. PRINT #2, " Page "; USING "###"; subPageCount
  526. PRINT #2, TAB(10); STRING$(80, 45)
  527. PRINT #2,
  528. subPageCount = subPageCount + 1
  529. LineCount = 4
  530.  
  531. END SUB
  532.  
  533. SUB WaitforAnswer (A$)
  534.  
  535. Answer$ = ""
  536. A$ = ""
  537.  DO
  538.    A$ = UCASE$(INKEY$)
  539.  LOOP WHILE A$ = ""
  540.  
  541. END SUB
  542.  
  543. SUB WriteLine
  544.  
  545. IF LEN(Line$) > 80 THEN
  546.    CALL SplitLine
  547.    PRINT #2, TAB(10); Line1$
  548.    PRINT #2, TAB(4); "<<*>>  ";
  549.    PRINT #2, Line2$
  550.    LineCount = LineCount + 2
  551. END IF
  552. IF LEN(Line$) <= 80 THEN
  553.    PRINT #2, TAB(10); Line$
  554.    LineCount = LineCount + 1
  555. END IF
  556. IF LineCount = 82 THEN
  557.    CALL ProgramTitle
  558.    CALL SubTitle
  559. END IF
  560.  
  561. END SUB
  562.  
  563.