home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / mbug / mbug106.arc / DBSRC102.LBR / DBSOURCE.BQS / DBSOURCE.BAS
BASIC Source File  |  1979-12-31  |  8KB  |  194 lines
  1. 10 '    DBSOURCE.BAS Version 1.02 (C) Copyright 1985 by Merlin R. Null
  2. 20 '    To read or create a source file from encoded dBASE II .CMD files
  3. 30 '    This program may not be sold seperately or as part of any collection"
  4. 40 '    of programs without the written permission of the author:
  5. 50 '    Merlin R. Null, P.O. Box 9422, N. Hollywood, CA 91609, (818) 762-1429
  6. 60 DEFINT A-Z
  7. 70 DIM TOKEN$(67)
  8. 80 WIDTH LPRINT 255
  9. 90 ON ERROR GOTO 1390    'Used mostly to detect incorrect filename
  10. 100 BL$=CHR$(7)
  11. 110 OPEN "I",#1,"CLS.DAT"
  12. 120 WHILE NOT EOF(1)
  13. 130   LINE INPUT #1, A$
  14. 140   A=VAL(A$)
  15. 150   CLS$=CLS$+CHR$(A)
  16. 160 WEND
  17. 170 CLOSE #1
  18. 180 FOR I=1 TO 67
  19. 190   READ TOKEN$(I)
  20. 200 NEXT I
  21. 210 PRINT CLS$:PRINT
  22. 220 PRINT TAB(10)"DBSOURCE  Version 1.02   -   3/1/85"
  23. 230 PRINT STRING$(4,10)
  24. 240 PRINT"Options:    P        Send output to Printer"
  25. 250 PRINT"        F        Send output to File"
  26. 260 PRINT"        N        No console output"
  27. 270 PRINT
  28. 280 PRINT"Examples:    B:FOO.CMD PN    Printer output only"
  29. 290 PRINT"        FOO.CMD F    Output to file and console"
  30. 300 PRINT"        A:        Displays directory of A:"
  31. 310 PRINT"        ?        Read the HELP file"
  32. 320 PRINT"        <RET>        Redisplays this screen"
  33. 330 PRINT:PRINT
  34. 340 PRINT        'return here after directory call
  35. 350 LINE INPUT"Filename.CMD or Drive:? ";NF$
  36. 360 CONOFF=0:LINEPRINT=0:WRITESRC=0:OPTFLAG=0:NFLEN=0:FULLNAME$=""
  37. 370 IF NF$="" THEN 210            'Redisplay start screen
  38. 380 IF NF$="?" THEN OPEN "I",#1,"DBSOURCE.HLP" ELSE 510
  39. 390   PRINT CLS$
  40. 400   FOR LINES=1 TO 20
  41. 410     IF EOF(1) THEN 460 ELSE LINE INPUT #1,HELP$
  42. 420     PRINT HELP$
  43. 430   NEXT LINES
  44. 440   PRINT
  45. 450   PRINT TAB(7)"<Press any key to continue reading help file>"
  46. 460   PRINT TAB(12)"Press <ESC> to return to DBSOURCE ";
  47. 470   FINISHED$=INPUT$(1)
  48. 480   IF FINISHED$<>CHR$(27) THEN 390
  49. 490   CLOSE #1
  50. 500   GOTO 210
  51. 510 FOR I=1 TO LEN(NF$)        'Convert lower to upper case & detect options
  52. 520   BYTE$=MID$(NF$,I,1)
  53. 530   IF ASC(BYTE$)>96 AND ASC(BYTE$)<123 THEN BYTE$=CHR$(ASC(BYTE$)-32)
  54. 540   FULLNAME$=FULLNAME$+BYTE$
  55. 550   IF BYTE$=" " THEN OPTFLAG=-1        'Flag start of options
  56. 560   IF NOT OPTFLAG THEN 600
  57. 570   IF BYTE$="P" THEN LINEPRINT=-1        'Detect print option
  58. 580   IF BYTE$="F" THEN WRITESRC=-1        'Detect file option
  59. 590   IF BYTE$="N" THEN CONOFF=-1         'Detect console off
  60. 600   IF NFLEN THEN 620
  61. 610   IF BYTE$="." THEN NFLEN=I+3        'Find filename length
  62. 620 NEXT I
  63. 630 IF CONOFF AND NOT LINEPRINT AND NOT WRITESRC THEN PRINT CLS$; ELSE 680
  64. 640   PRINT STRING$(5,10)
  65. 650   PRINT"N option may not be selected alone, only as NF or PN - try again.";
  66. 660   PRINT BL$
  67. 670   GOTO 340
  68. 680 IF NFLEN>3 THEN FULLNAME$=LEFT$(FULLNAME$,NFLEN)   'Remove extra charcters
  69. 690 IF MID$(FULLNAME$,2,1)=";" THEN MID$(FULLNAME$,2,1)=":"
  70. 700 IF LEN(FULLNAME$)=2 AND MID$(FULLNAME$,2,1)=":" THEN
  71.       DIR$=LEFT$(FULLNAME$,1)+":*.*" ELSE 740
  72. 710   PRINT CLS$:PRINT"Directory of drive ";LEFT$(DIR$,2)
  73. 720   FILES DIR$
  74. 730   GOTO 340
  75. 740 IF RIGHT$(FULLNAME$,3)<>"CMD" THEN PRINT CLS$;STRING$(5,10) ELSE 780
  76. 750   PRINT BL$;CHR$(34);FULLNAME$;CHR$(34);
  77. 760   PRINT" is not a dBASE II command file - try again."
  78. 770   GOTO 340
  79. 780 FILENAME$=LEFT$(FULLNAME$,NFLEN-3)    'Remove extension
  80. 790 IF NOT WRITESRC THEN 1020
  81. 800 TMPNAME$=FILENAME$+"TMP"
  82. 810 SRCNAME$=FILENAME$+"SRC"
  83. 820 BAKNAME$=FILENAME$+"BAK"
  84. 830 OPEN "I",#1,SRCNAME$    'See if <filename>.SRC exists
  85. 840 CLOSE #1            'Close, if found.  Else error trap gets it
  86. 850 PRINT CLS$;STRING$(8,10)
  87. 860 PRINT TAB(20)"[]=========[]"
  88. 870 PRINT TAB(20)"[] WARNING []"
  89. 880 PRINT TAB(20)"[]=========[]"
  90. 890 PRINT
  91. 900 PRINT SRCNAME$;" already exists!  A 'NO' here will cause the current"
  92. 910 PRINT SRCNAME$;" to be renamed to ";BAKNAME$
  93. 920 PRINT:PRINT
  94. 930 PRINT"Do you wish to overwrite ";SRCNAME$;" (Yes/No/Quit)";
  95. 940 INPUT OVERWRITE$
  96. 950 IF LEFT$(OVERWRITE$,1)="Q" OR LEFT$(OVERWRITE$,1)="q" THEN 1310
  97. 960 IF LEFT$(OVERWRITE$,1)="Y" OR LEFT$(OVERWRITE$,1)="y" THEN 1020
  98. 970 IF LEFT$(OVERWRITE$,1)<>"N" AND LEFT$(OVERWRITE$,1)<>"n" THEN 850
  99. 980 RENAMESRC=-1        'Flag to rename old source file
  100. 990 OPEN "I",#1,BAKNAME$    'See if <filename>.BAK exists
  101. 1000 CLOSE #1            'Close, if found.  Else error trap gets it 
  102. 1010 ERASEBAK=-1        'Flag to erase old backup
  103. 1020 OPEN "I",#2,FULLNAME$
  104. 1030 IF WRITESRC THEN OPEN "O",#3,TMPNAME$
  105. 1040 PRINT CLS$;TAB(20)"^S to pause  -  ^C to end"
  106. 1050 WHILE NOT EOF(2)
  107. 1060   LINE INPUT #2,TXT$
  108. 1070   PRN$=""
  109. 1080   FOR BYTE=1 TO LEN(TXT$)
  110. 1090     IF ASC(MID$(TXT$,BYTE,1))<128 THEN PRN$=PRN$+MID$(TXT$,BYTE,1):
  111.          GOTO 1150
  112. 1100     IF BYTE>1 THEN 1140
  113. 1110     IF ASC(MID$(TXT$,BYTE,1))>127 AND ASC(MID$(TXT$,BYTE,1))<195 THEN
  114.          PRN$=PRN$+TOKEN$(ASC(MID$(TXT$,BYTE,1))-127)
  115. 1120     IF LEN(TXT$)=1 THEN 1150
  116. 1130     PRN$=PRN$+" ":GOTO 1150
  117. 1140     IF ASC(MID$(TXT$,BYTE,1))>127 THEN PRN$=PRN$+
  118.          CHR$(ASC(MID$(TXT$,BYTE,1))XOR 255)
  119. 1150   NEXT BYTE
  120. 1160   IF NOT CONOFF THEN PRINT PRN$
  121. 1170   IF LINEPRINT THEN LPRINT PRN$
  122. 1180   IF WRITESRC THEN PRINT #3, PRN$
  123. 1190   QUIT$=INKEY$
  124. 1200   IF QUIT$<>"" THEN GOSUB 1360
  125. 1210 WEND
  126. 1220 PRINT
  127. 1230 CLOSE
  128. 1240 IF NOT WRITESRC THEN 1310
  129. 1250 PRINT
  130. 1260 IF ERASEBAK THEN KILL BAKNAME$:PRINT"Erasing  ";BAKNAME$
  131. 1270 IF RENAMESRC THEN NAME SRCNAME$ AS BAKNAME$ ELSE 1290
  132. 1280 PRINT"Changing ";SRCNAME$;" to ";BAKNAME$
  133. 1290 IF LEFT$(OVERWRITE$,1)="Y" OR LEFT$(OVERWRITE$,1)="y" THEN
  134.      KILL SRCNAME$:PRINT"Erasing  ";SRCNAME$
  135. 1300 NAME TMPNAME$ AS SRCNAME$:PRINT"Changing ";TMPNAME$;" to ";SRCNAME$
  136. 1310 PRINT
  137. 1320 INPUT"Are you finished";ANS$
  138. 1330 IF LEFT$(ANS$,1)<>"Y" AND LEFT$(ANS$,1)<>"y" THEN 210
  139. 1340 END
  140. 1350 'The following quit and hold routine is for BASCOM only
  141. 1360 IF QUIT$=CHR$(3) THEN 1340                'If ^C then end
  142. 1370 IF QUIT$=CHR$(19) THEN WHILE INKEY$="":WEND    'If ^S then hold
  143. 1380 RETURN
  144. 1390 IF ERR=53 AND ERL=830 THEN CLOSE #1:RESUME 1020
  145. 1400 IF ERR=53 AND ERL=990 THEN CLOSE #1:RESUME 1020
  146. 1410 IF ERR=53 AND ERL=110 THEN CLOSE #1 ELSE 1650
  147. 1420   PRINT STRING$(18,10)
  148. 1430   PRINT BL$;"CLS.DAT, the clear screen data file, not found."
  149. 1440   PRINT"Please enter your clear screen sequence"
  150. 1450   PRINT"one byte at a time in Decimal numbers.  End your"
  151. 1460   PRINT"entries with a <RETURN> to generate CLS.DAT"
  152. 1470   PRINT
  153. 1480   FOR I=1 TO 9
  154. 1490     PRINT"Clear Screen character";I;
  155. 1500     LINE INPUT C$
  156. 1510     IF C$="" AND I>1 THEN 1600
  157. 1520     IF C$="" THEN 1490
  158. 1530     IF LEN(C$)>3 THEN 1490
  159. 1540     FOR J=1 TO LEN(C$)
  160. 1550       IF ASC(MID$(C$,J,1))<48 OR ASC(MID$(C$,J,1))>57 THEN PRINT BL$;
  161.            "Whole decimal numbers only.":GOTO 1490
  162. 1560     NEXT J
  163. 1570     IF I>1 THEN CLR$=CLR$+CHR$(13)+CHR$(10)
  164. 1580     CLR$=CLR$+C$
  165. 1590   NEXT I
  166. 1600   PRINT"Writing CLS.DAT";
  167. 1610   OPEN "O",#1,"CLS.DAT"
  168. 1620   PRINT #1,CLR$
  169. 1630   CLOSE #1
  170. 1640   RESUME 110
  171. 1650 IF ERR=64 THEN CLOSE ELSE 1690
  172. 1660   PRINT CLS$;STRING$(5,10)
  173. 1670   PRINT BL$;CHR$(34);FULLNAME$;CHR$(34);" is a bad file name - try again."
  174. 1680   RESUME 340
  175. 1690 IF ERR=53 AND ERL=1020 THEN CLOSE #2 ELSE 1730
  176. 1700   PRINT CLS$;STRING$(5,10)
  177. 1710   PRINT BL$;CHR$(34);FULLNAME$;CHR$(34);" not found - try again."
  178. 1720   RESUME 340
  179. 1730 IF ERR=53 AND ERL=380 THEN  CLOSE #1 ELSE 1770
  180. 1740   PRINT CLS$;STRING$(5,10)
  181. 1750   PRINT BL$;"The Help file, DBSOURCE.HLP, is missing from this disk!";BL$
  182. 1760   RESUME 340
  183. 1770 ON ERROR GOTO 0
  184. 1780 DATA "IF","ELSE","ENDIF","DO","ENDDO","CASE","OTHERWISE","ENDCASE"
  185. 1790 DATA "DO WHILE","DO CASE","STORE","?","RELEASE","RETURN","SELECT","@"
  186. 1800 DATA "ACCEPT","APPEND","BROWSE","CALL","CANCEL","CHANGE","CLEAR","COPY"
  187. 1810 DATA "COUNT","CREATE","DELETE","DISPLAY","CONTINUE","EDIT","EJECT","ERASE"
  188. 1820 DATA "GOTO","FIND","HELP","INDEX","INPUT","INSERT","JOIN","LIST","LOAD"
  189. 1830 DATA "LOCATE","LOOP","MODIFY","PACK","POKE","QUIT","READ","RECALL"
  190. 1840 DATA "REINDEX","REMARK","RENAME","REPLACE","REPORT","RESET","RESTORE"
  191. 1850 DATA "SAVE","SET","SKIP","SORT","SUM","TEXT","TOTAL","UNLOCK","UPDATE"
  192. 1860 DATA "USE","WAIT"
  193. EPORT","RESET","RESTORE"
  194. 1850 DATA "SAVE","SET","SKIP","SOR