home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / mbug / mbug106.arc / ENCODE6.LBR / ENCODE.BQS / ENCODE.BAS
BASIC Source File  |  1979-12-31  |  10KB  |  262 lines
  1. 10 '    ENCODE.BAS Version 1.06 (C) Copyright 1985, 1986 by Merlin R. Null
  2. 20 '    To create pseudo compiled dBASE II .CMD files.
  3. 30 '    This program may not be sold separately 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),WORDLEN(67)
  8. 80 ON ERROR GOTO 2090    'Used mostly to detect incorrect filename
  9. 90 WIDTH LPRINT 255
  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),WORDLEN(I)
  20. 200 NEXT I
  21. 210    ' Read CP/M Command Tail for Filename.  Compiled Version Only.
  22. 220 CTLEN=PEEK(128)
  23. 230 IF CTLEN<2 THEN 290
  24. 240 FOR I=2 TO CTLEN
  25. 250   NF$=NF$+CHR$(PEEK(128+I))
  26. 260 NEXT I
  27. 270 CLFLAG=-1
  28. 280 GOTO 460
  29. 290 PRINT CLS$
  30. 300 PRINT"ENCODE version 1.06  3/2/86 (C) Copyright 1985, 1986 by ";
  31. 310 PRINT"Merlin R. Null"
  32. 320 PRINT STRING$(4,10)
  33. 330 PRINT"Option:     N        No console display of input file"
  34. 340 PRINT
  35. 350 PRINT"Examples:    B:FOO.SRC N    No console display"
  36. 360 PRINT"        FOO        Output to file with console display"
  37. 370 PRINT"        A:        Displays directory of A:"
  38. 380 PRINT"        X        Exit to system"
  39. 390 PRINT"        ?        Read the Help file"
  40. 400 PRINT"        <RET>        Redisplays this screen"
  41. 410 PRINT STRING$(4,10)
  42. 420 PRINT
  43. 430 LINE INPUT"Filename[.SRC] or Drive:? ";NF$
  44. 440 NFLEN=0:CONOFF=0:OPTFLAG=0:FULLNAME$=""
  45. 450 IF NF$="" THEN 290            'Redisplay start screen
  46. 460 IF NF$="?" THEN OPEN "I",#1,"ENCODE.HLP" ELSE 600
  47. 470   PRINT CLS$
  48. 480   FOR LINES=1 TO 20
  49. 490     IF EOF(1) THEN 540 ELSE LINE INPUT #1,HELP$
  50. 500     PRINT HELP$
  51. 510   NEXT
  52. 520   PRINT
  53. 530   PRINT TAB(7)"<Press any key to continue reading help file>"
  54. 540   PRINT TAB(12)"Press <ESC> to return to ENCODE ";
  55. 550   FINISHED$=INPUT$(1)
  56. 560   IF FINISHED$<>CHR$(27) THEN 470
  57. 570   CLOSE #1
  58. 580   CLFLAG=0
  59. 590   GOTO 290
  60. 600 FOR I=1 TO LEN(NF$)        'Convert lower to upper case & detect options
  61. 610   BYTE$=MID$(NF$,I,1)
  62. 620   IF ASC(BYTE$)>96 AND ASC(BYTE$)<123 THEN BYTE$=CHR$(ASC(BYTE$)-32)
  63. 630   IF BYTE$=" " THEN OPTFLAG=-1        'Flag start of options
  64. 640   IF NOT OPTFLAG THEN FULLNAME$=FULLNAME$+BYTE$
  65. 650   IF NOT OPTFLAG THEN 670
  66. 660   IF BYTE$="N" THEN CONOFF=-1        'Detect console off
  67. 670 NEXT
  68. 680 IF FULLNAME$="X" THEN PRINT CLS$:GOTO 1780
  69. 690 IF MID$(FULLNAME$,2,1)=";" THEN MID$(FULLNAME$,2,1)=":"
  70. 700 IF LEN(FULLNAME$)=2 AND MID$(FULLNAME$,2,1)=":" THEN PRINT CLS$ ELSE 750
  71. 710   DIR$=FULLNAME$+"*.*"
  72. 720   PRINT"Directory of drive ";FULLNAME$
  73. 730   FILES DIR$
  74. 740   GOTO 420
  75. 750 IF INSTR(FULLNAME$,".")=0 THEN FULLNAME$=FULLNAME$+".SRC"
  76. 760 IF RIGHT$(FULLNAME$,3)<>"SRC" THEN PRINT CLS$;STRING$(5,10) ELSE 790
  77. 770   PRINT BL$;FULLNAME$;" must have the extension .SRC - try again."
  78. 780   GOTO 420
  79. 790 FILENAME$=LEFT$(FULLNAME$,LEN(FULLNAME$)-4)
  80. 800 TMPNAME$=FILENAME$+".TMP"
  81. 810 CMDNAME$=FILENAME$+".CMD"
  82. 820 OLDNAME$=FILENAME$+".OLD"
  83. 830 OPEN "I",#1,CMDNAME$    'See if <filename>.CMD exists
  84. 840 CLOSE #1            'Close, if found. Else error trap gets it
  85. 850 PRINT CLS$;STRING$(7,10);BL$
  86. 860 PRINT TAB(20)"[]=========[]"
  87. 870 PRINT TAB(20)"[] WARNING []"
  88. 880 PRINT TAB(20)"[]=========[]"
  89. 890 PRINT:PRINT
  90. 900 PRINT CMDNAME$;" already exists!  If you answer NO, the old ";CMDNAME$
  91. 910 PRINT"will be renamed to ";OLDNAME$
  92. 920 PRINT STRING$(3,10)
  93. 930 PRINT"Do you wish to overwrite ";CMDNAME$;" (Yes/No/Quit)";
  94. 940 INPUT OVERWRITE$
  95. 950 IF LEFT$(OVERWRITE$,1)="Y" OR LEFT$(OVERWRITE$,1)="y" THEN 1020
  96. 960 IF LEFT$(OVERWRITE$,1)="Q" OR LEFT$(OVERWRITE$,1)="q" THEN 1780
  97. 970 IF LEFT$(OVERWRITE$,1)<>"N" AND LEFT$(OVERWRITE$,1)<>"n" THEN 850
  98. 980 RENAMECMD=-1
  99. 990 OPEN "I",#2,OLDNAME$    'See if <filename>.OLD exists.
  100. 1000 CLOSE #2            'Close, if found. Else error trap gets it
  101. 1010 ERASEOLD=-1            'Flag to kill <filename>.OLD
  102. 1020 OPEN "I",#3,FULLNAME$
  103. 1030 OPEN "O",#1,TMPNAME$
  104. 1040 IF CONOFF THEN PRINT:PRINT"    <No console output>" ELSE PRINT CLS$
  105. 1050 PRINT
  106. 1060 PRINT"    ^S to Pause  -  ^C to Abort"
  107. 1070 PRINT
  108. 1080 LINES=0
  109. 1090 WHILE NOT EOF(3)
  110. 1100   LINES=LINES+1
  111. 1110   LINE INPUT #3,TXT$
  112. 1120   IF RIGHT$(TXT$,1)=";" THEN TXT$=LEFT$(TXT$,LEN(TXT$)-1) ELSE 1220
  113. 1130     LINE INPUT #3,MORE$
  114. 1140     BLANK=0
  115. 1150     LINES=LINES+1
  116. 1160     FOR CHR=1 TO LEN(MORE$)
  117. 1170       CHRVAL=ASC(MID$(MORE$,CHR,1))
  118. 1180       IF CHRVAL<>32 AND CHRVAL<>9 THEN TXT$=TXT$+MID$(MORE$,CHR)ELSE 1200
  119. 1190         CHR=LEN(MORE$)
  120. 1200     NEXT
  121. 1210     GOTO 1120
  122. 1220   TEMP$=TXT$:START=0:BLANK=0
  123. 1230   TEXTLEN=LEN(TXT$)
  124. 1240   FOR CHAR=1 TO TEXTLEN
  125. 1250     CHARVAL=ASC(MID$(TEMP$,CHAR,1))
  126. 1260     IF CHARVAL<123 AND CHARVAL>96 THEN MID$(TEMP$,CHAR,1)=CHR$(CHARVAL-32)
  127. 1270     IF START THEN 1290
  128. 1280     IF CHARVAL=32 OR CHARVAL=9 THEN BLANK=BLANK+1 ELSE START=CHAR
  129. 1290     IF CHAR-BLANK>8 THEN CHAR=TEXTLEN
  130. 1300   NEXT
  131. 1310   IF LEN(TXT$)-BLANK=0 AND TXT=0 THEN 1630
  132. 1320   IF TXT THEN PRN$=TXT$ ELSE 1350
  133. 1330     IF MID$(TEMP$,1+BLANK,4)="ENDT" THEN PRN$="ENDT":TXT=0
  134. 1340     GOTO 1610
  135. 1350   IF MID$(TXT$,1+BLANK,1)="*" OR MID$(TXT$,1+BLANK,4)="NOTE" THEN 1630
  136. 1360   IF MID$(TXT$,1+BLANK,1)="&" THEN PRN$=TXT$:GOTO 1610
  137. 1370   PRN$="":FOUND=0
  138. 1380   IF MID$(TEMP$,1+BLANK,4)="GOTO" THEN PRN$=PRN$+CHR$(160) ELSE 1410
  139. 1390     LENGTH=4
  140. 1400     GOTO 1540
  141. 1410   IF MID$(TEMP$,1+BLANK,7)="DO WHIL" THEN PRN$=PRN$+CHR$(136) ELSE 1440
  142. 1420     IF MID$(TEMP$,1+BLANK,8)="DO WHILE" THEN LENGTH=8 ELSE LENGTH =7
  143. 1430     GOTO 1540
  144. 1440   IF MID$(TEMP$,1+BLANK,7)="DO CASE" THEN PRN$=PRN$+CHR$(137) ELSE 1470
  145. 1450     LENGTH=7
  146. 1460     GOTO 1540
  147. 1470   FOR TOKEN=1 TO 67
  148. 1480     IF MID$(TEMP$,1+BLANK,WORDLEN(TOKEN))=TOKEN$(TOKEN) THEN
  149.          PRN$=PRN$+CHR$(TOKEN+127):LENGTH=WORDLEN(TOKEN):FOUND=TOKEN:TOKEN=67
  150.          :GOTO 1500
  151. 1490     IF MID$(TEMP$,1+BLANK,4)=LEFT$(TOKEN$(TOKEN),4) THEN
  152.          PRN$=PRN$+CHR$(TOKEN+127):LENGTH=4:FOUND=TOKEN:TOKEN=67
  153. 1500   NEXT
  154. 1510   IF FOUND=3 OR FOUND=5 OR FOUND=8 THEN 1610
  155. 1520   IF NOT TXT AND FOUND=62 THEN TXT=-1
  156. 1530   IF FOUND<1 THEN 1800
  157. 1540   BEGIN=BLANK+LENGTH+1
  158. 1550   FOR BYTE=BEGIN TO TEXTLEN
  159. 1560     CHARVAL=ASC(MID$(TXT$,BYTE,1))
  160. 1570     IF CHARVAL>128 THEN 1920
  161. 1580     IF BYTE=BEGIN AND CHARVAL=32 OR BYTE=BEGIN AND CHARVAL=9 THEN 1600
  162. 1590     PRN$=PRN$+CHR$(ASC(MID$(TXT$,BYTE,1))XOR 255)
  163. 1600   NEXT
  164. 1610   IF NOT CONOFF THEN PRINT TXT$
  165. 1620   PRINT #1, PRN$
  166. 1630   QUIT$=INKEY$:IF QUIT$<>"" THEN GOSUB 2040
  167. 1640 WEND
  168. 1650 CLOSE
  169. 1660 PRINT
  170. 1670 IF ERASEOLD THEN KILL OLDNAME$ ELSE 1690
  171. 1680   PRINT"Erasing ";OLDNAME$
  172. 1690 IF RENAMECMD THEN NAME CMDNAME$ AS OLDNAME$ ELSE 1710
  173. 1700   PRINT"Changing ";CMDNAME$;" to ";OLDNAME$
  174. 1710 IF OVERWRITE$="Y" OR OVERWRITE$="y" THEN KILL CMDNAME$ ELSE 1730
  175. 1720   PRINT"Erasing ";CMDNAME$
  176. 1730 NAME TMPNAME$ AS CMDNAME$:PRINT"Changing ";TMPNAME$;" to ";CMDNAME$
  177. 1740 PRINT
  178. 1750 IF CLFLAG THEN 1780
  179. 1760 INPUT"Are you finished";ANS$
  180. 1770 IF LEFT$(ANS$,1)<>"Y" AND LEFT$(ANS$,1)<>"y" THEN 290
  181. 1780 END
  182. 1790 CLOSE
  183. 1800 PRINT BL$
  184. 1810 PRINT"[]==============[] This file contains incorrect syntax for a";BL$
  185. 1820 PRINT"[]   ABORTING   [] dBASE II .CMD file.  All lines not between"
  186. 1830 PRINT"[]==============[] TEXT and ENDTEXT must begin with a reserved"
  187. 1840 PRINT"                   word , '*' (remark) or '&' (macro character)
  188. 1850 PRINT
  189. 1860 PRINT"The error was found on line";LINES;"of ";FULLNAME$;", it reads:"
  190. 1870 PRINT
  191. 1880 PRINT "'";TXT$;"'"
  192. 1890 PRINT
  193. 1900 KILL TMPNAME$
  194. 1910 GOTO 1780
  195. 1920 CLOSE
  196. 1930 PRINT BL$
  197. 1940 PRINT"****ABORTING**** This file contains characters with the 8th bit set!"
  198. 1950 PRINT BL$
  199. 1960 PRINT"The error was in line";LINES;"of ";FULLNAME$;", it reads:"
  200. 1970 PRINT
  201. 1980 PRINT"'";TXT$;"'"
  202. 1990 KILL TMPNAME$
  203. 2000 PRINT
  204. 2010 GOTO 1780
  205. 2020 '    The ^C and ^S handling only works with BASCOM, not the interpreter.
  206. 2030 PRINT
  207. 2040 IF QUIT$=CHR$(3) THEN CLOSE ELSE 2070
  208. 2050   PRINT BL$;"****ABORTING**** ^C entered from keyboard.  No files changed"
  209. 2060   GOTO 1780
  210. 2070 IF QUIT$=CHR$(19) THEN WHILE INKEY$="":WEND
  211. 2080 RETURN
  212. 2090 IF ERR=53 AND ERL=1020 THEN CLOSE #3 ELSE 2130
  213. 2100   PRINT CLS$;STRING$(5,10)
  214. 2110   PRINT CHR$(34);FULLNAME$;CHR$(34);" not found - try again.";BL$
  215. 2120   RESUME 420
  216. 2130 IF ERR=53 AND ERL=830 THEN CLOSE #1:RESUME 1020
  217. 2140 IF ERR=53 AND ERL=990 THEN CLOSE #2:RESUME 1020
  218. 2150 IF ERR=53 AND ERL=110 THEN CLOSE #1 ELSE 2390
  219. 2160   PRINT STRING$(18,10)
  220. 2170   PRINT BL$;"CLS.DAT, the clear screen data file, not found."
  221. 2180   PRINT"Please enter your clear screen sequence"
  222. 2190   PRINT"one byte at a time in Decimal numbers.  End your"
  223. 2200   PRINT"entries with a <RETURN> to generate CLS.DAT"
  224. 2210   PRINT
  225. 2220   FOR I=1 TO 9
  226. 2230     PRINT"Clear Screen character";I;
  227. 2240     LINE INPUT C$
  228. 2250     IF C$="" AND I>1 THEN 2340
  229. 2260     IF C$="" THEN 2230
  230. 2270     IF LEN(C$)>3 THEN 2230
  231. 2280     FOR J=1 TO LEN(C$)
  232. 2290       IF ASC(MID$(C$,J,1))<48 OR ASC(MID$(C$,J,1))>57 THEN PRINT BL$;
  233.            "Whole decimal numbers only.":GOTO 2230
  234. 2300     NEXT
  235. 2310     IF I>1 THEN CLR$=CLR$+CHR$(13)+CHR$(10)
  236. 2320     CLR$=CLR$+C$
  237. 2330   NEXT
  238. 2340   PRINT"Writing CLS.DAT";
  239. 2350   OPEN "O",#1,"CLS.DAT"
  240. 2360   PRINT #1,CLR$
  241. 2370   CLOSE #1
  242. 2380   RESUME 100
  243. 2390 IF ERR=53 AND ERL=460 THEN PRINT CLS$;STRING$(5,10); ELSE 2420
  244. 2400   PRINT BL$;"The Help file, ENCODE.HLP, is not on this disk!";BL$
  245. 2410   RESUME 420
  246. 2420 IF ERR=64 THEN CLOSE ELSE 2460
  247. 2430   PRINT CLS$;STRING$(5,10)
  248. 2440   PRINT BL$;CHR$(34);FULLNAME$;CHR$(34);" is a bad file name - try again."
  249. 2450   RESUME 420
  250. 2460 ON ERROR GOTO 0
  251. 2470 DATA "IF",2,"ELSE",4,"ENDIF",5,"DO",2,"ENDDO",5,"CASE",4,"OTHERWISE",9
  252. 2480 DATA "ENDCASE",7,"DO WHILE",8,"DO CASE",7,"STORE",5,"?",1,"RELEASE",7
  253. 2490 DATA "RETURN",6,"SELECT",6,"@",1,"ACCEPT",6,"APPEND",6,"BROWSE",6,"CALL",4
  254. 2500 DATA "CANCEL",6,"CHANGE",6,"CLEAR",5,"COPY",4,"COUNT",5,"CREATE",6
  255. 2510 DATA "DELETE",6,"DISPLAY",7,"CONTINUE",8,"EDIT",4,"EJECT",5,"ERASE",5
  256. 2520 DATA "GO",2,"FIND",4,"HELP",4,"INDEX",5,"INPUT",5,"INSERT",6,"JOIN",4
  257. 2530 DATA "LIST",4,"LOAD",4,"LOCATE",6,"LOOP",4,"MODIFY",6,"PACK",4,"POKE",4
  258. 2540 DATA "QUIT",4,"READ",4,"RECALL",6,"REINDEX",7,"REMARK",6,"RENAME",6
  259. 2550 DATA "REPLACE",7,"REPORT",6,"RESET",5,"RESTORE",7,"SAVE",4,"SET",3
  260. 2560 DATA "SKIP",4,"SORT",4,"SUM",3,"TEXT",4,"TOTAL",5,"UNLOCK",6,"UPDATE",6
  261. 2570 DATA "USE",3,"WAIT",4
  262. t o