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