10 '	ENCODE.BAS Version 1.05 (C) Copyright 1985 by Merlin R. Null
20 '	To create pseudo compiled dBASE II .CMD files.
30 '	This program may not be sold separately or as part of any collection"
40 '	of programs without the written permission of the author:
50 '	Merlin R. Null, P.O. Box 9422, N. Hollywood, CA 91609, (818)762-1429
60 DEFINT A-Z
70 DIM TOKEN$(67),WORDLEN(67)
80 ON ERROR GOTO 1980	'Used mostly to detect incorrect filename
90 WIDTH LPRINT 255
100 BL$=CHR$(7)
110 OPEN "I",#1,"CLS.DAT"
120 WHILE NOT EOF(1)
130   LINE INPUT #1, A$
140   A=VAL(A$)
150   CLS$=CLS$+CHR$(A)
160 WEND
170 CLOSE #1
180 FOR I=1 TO 67
190   READ TOKEN$(I),WORDLEN(I)
200 NEXT I
210 PRINT CLS$:PRINT
220 PRINT TAB(10)"ENCODE  -  Version 1.05     3/20/85"
230 PRINT STRING$(4,10)
240 PRINT"Option: 	N		No console display of input file"
250 PRINT
260 PRINT"Examples:	B:FOO.SRC N	No console display"
270 PRINT"		FOO.SRC		Output to file with console display"
280 PRINT"		A:		Displays directory of A:"
290 PRINT"		?		Read the Help file"
300 PRINT"		<RET>		Redisplays this screen"
310 PRINT STRING$(4,10)
320 PRINT
330 LINE INPUT"Filename.SRC or Drive:? ";NF$
340 NFLEN=0:CONOFF=0:OPTFLAG=0:FULLNAME$=""
350 IF NF$="" THEN 210			'Redisplay start screen
360 IF NF$="?" THEN OPEN "I",#1,"ENCODE.HLP" ELSE 490
370   PRINT CLS$
380   FOR LINES=1 TO 20
390     IF EOF(1) THEN 440 ELSE LINE INPUT #1,HELP$
400     PRINT HELP$
410   NEXT LINES
420   PRINT
430   PRINT TAB(7)"<Press any key to continue reading help file>"
440   PRINT TAB(12)"Press <ESC> to return to ENCODE ";
450   FINISHED$=INPUT$(1)
460   IF FINISHED$<>CHR$(27) THEN 370
470   CLOSE #1
480   GOTO 210
490 FOR I=1 TO LEN(NF$)		'Convert lower to upper case & detect options
500   BYTE$=MID$(NF$,I,1)
510   IF ASC(BYTE$)>96 AND ASC(BYTE$)<123 THEN BYTE$=CHR$(ASC(BYTE$)-32)
520   FULLNAME$=FULLNAME$+BYTE$
530   IF BYTE$=" " THEN OPTFLAG=-1		'Flag start of options
540   IF NOT OPTFLAG THEN 560
550   IF BYTE$="N" THEN CONOFF=-1		'Detect console off
560   IF NFLEN THEN 580
570   IF BYTE$="." THEN NFLEN=I+3		'Find filename length
580 NEXT I
590 IF NFLEN>3 THEN FULLNAME$=LEFT$(FULLNAME$,NFLEN)'Drop option from filename
600 IF MID$(FULLNAME$,2,1)=";" THEN MID$(FULLNAME$,2,1)=":" 'ZCPR like (A;)
610 IF LEN(FULLNAME$)=2 AND MID$(FULLNAME$,2,1)=":" THEN PRINT CLS$ ELSE 660
620   DIR$=FULLNAME$+"*.*"
630   PRINT"Directory of drive ";FULLNAME$
640   FILES DIR$
650   GOTO 320
660 IF RIGHT$(FULLNAME$,3)<>"SRC" THEN PRINT CLS$;STRING$(5,10) ELSE 690
670   PRINT BL$;FULLNAME$;" must have the extension .SRC - try again."
680   GOTO 320
690 FILENAME$=LEFT$(FULLNAME$,NFLEN-3)
700 TMPNAME$=FILENAME$+"TMP"
710 CMDNAME$=FILENAME$+"CMD"
720 OLDNAME$=FILENAME$+"OLD"
730 OPEN "I",#1,CMDNAME$	'See if <filename>.CMD exists
740 CLOSE #1			'Close, if found. Else error trap gets it
750 PRINT CLS$;STRING$(7,10);BL$
760 PRINT TAB(20)"[]=========[]"
770 PRINT TAB(20)"[] WARNING []"
780 PRINT TAB(20)"[]=========[]"
790 PRINT:PRINT
800 PRINT CMDNAME$;" already exists!  If you answer NO, the old ";CMDNAME$
810 PRINT"will be renamed to ";OLDNAME$
820 PRINT:PRINT
830 PRINT"Do you wish to overwrite ";CMDNAME$;" (Yes/No/Quit)";
840 INPUT OVERWRITE$
850 IF LEFT$(OVERWRITE$,1)="Y" OR LEFT$(OVERWRITE$,1)="y" THEN 920
860 IF LEFT$(OVERWRITE$,1)="Q" OR LEFT$(OVERWRITE$,1)="q" THEN 1640
870 IF LEFT$(OVERWRITE$,1)<>"N" AND LEFT$(OVERWRITE$,1)<>"n" THEN 750
880 RENAMECMD=-1
890 OPEN "I",#2,OLDNAME$	'See if <filename>.OLD exists.
900 CLOSE #2			'Close, if found. Else error trap gets it
910 ERASEOLD=-1			'Flag to kill <filename>.OLD
920 OPEN "I",#3,FULLNAME$
930 OPEN "O",#1,TMPNAME$
940 IF CONOFF THEN PRINT:PRINT"	<No console output>" ELSE PRINT CLS$
950 PRINT
960 PRINT"    ^S to Pause  -  ^C to Abort"
970 PRINT
980 LINES=0
990 WHILE NOT EOF(3)
1000   LINES=LINES+1
1010   LINE INPUT #3,TXT$
1020   IF LEN(TXT$)=0 THEN 1530
1030   IF RIGHT$(TXT$,1)=";" THEN TXT$=LEFT$(TXT$,LEN(TXT$)-1) ELSE 1130
1040     LINE INPUT #3,MORE$
1050     BLANK=0
1060     LINES=LINES+1
1070     FOR CHR=1 TO LEN(MORE$)
1080       CHRVAL=ASC(MID$(MORE$,CHR,1))
1090       IF CHRVAL<>32 AND CHRVAL<>9 THEN TXT$=TXT$+MID$(MORE$,CHR)ELSE 1110
1100         CHR=LEN(MORE$)
1110     NEXT CHR
1120     GOTO 1030
1130   TEMP$=TXT$:START=0:BLANK=0
1140   TEXTLEN=LEN(TXT$)
1150   FOR CHAR=1 TO TEXTLEN
1160     CHARVAL=ASC(MID$(TEMP$,CHAR,1))
1170     IF CHARVAL<123 AND CHARVAL>96 THEN MID$(TEMP$,CHAR,1)=CHR$(CHARVAL-32)
1180     IF START THEN 1200
1190     IF CHARVAL=32 OR CHARVAL=9 THEN BLANK=BLANK+1 ELSE START=CHAR
1200     IF CHAR-BLANK>8 THEN CHAR=TEXTLEN
1210   NEXT CHAR
1220   IF TXT THEN PRN$=TXT$ ELSE 1250
1230     IF MID$(TEMP$,1+BLANK,4)="ENDT" THEN TXT=0
1240     GOTO 1510
1250   IF MID$(TXT$,1+BLANK,1)="*" OR MID$(TXT$,1+BLANK,4)="NOTE" THEN 1530
1260   IF MID$(TXT$,1+BLANK,1)="&" THEN PRN$=TXT$:GOTO 1510
1270   PRN$="":FOUND=0
1280   IF MID$(TEMP$,1+BLANK,4)="GOTO" THEN PRN$=PRN$+CHR$(160) ELSE 1310
1290     LENGTH=4
1300     GOTO 1440
1310   IF MID$(TEMP$,1+BLANK,7)="DO WHIL" THEN PRN$=PRN$+CHR$(136) ELSE 1340
1320     IF MID$(TEMP$,1+BLANK,8)="DO WHILE" THEN LENGTH=8 ELSE LENGTH =7
1330     GOTO 1440
1340   IF MID$(TEMP$,1+BLANK,7)="DO CASE" THEN PRN$=PRN$+CHR$(137) ELSE 1370
1350     LENGTH=7
1360     GOTO 1440
1370   FOR TOKEN=1 TO 67
1380     IF MID$(TEMP$,1+BLANK,WORDLEN(TOKEN))=TOKEN$(TOKEN) THEN

         PRN$=PRN$+CHR$(TOKEN+127):LENGTH=WORDLEN(TOKEN):FOUND=TOKEN:TOKEN=67

         :GOTO 1400
1390     IF MID$(TEMP$,1+BLANK,4)=LEFT$(TOKEN$(TOKEN),4) THEN

         PRN$=PRN$+CHR$(TOKEN+127):LENGTH=4:FOUND=TOKEN:TOKEN=67
1400   NEXT TOKEN
1410   IF FOUND=3 OR FOUND=5 OR FOUND=8 THEN 1510
1420   IF NOT TXT AND FOUND=62 THEN TXT=-1
1430   IF FOUND<1 THEN 1690
1440   BEGIN=BLANK+LENGTH+1
1450   FOR BYTE=BEGIN TO TEXTLEN
1460     CHARVAL=ASC(MID$(TXT$,BYTE,1))
1470     IF CHARVAL>128 THEN 1810
1480     IF BYTE=BEGIN AND CHARVAL=32 OR BYTE=BEGIN AND CHARVAL=9 THEN 1500
1490     PRN$=PRN$+CHR$(ASC(MID$(TXT$,BYTE,1))XOR 255)
1500   NEXT BYTE
1510   IF NOT CONOFF THEN PRINT TXT$
1520   PRINT #1, PRN$
1530   QUIT$=INKEY$:IF QUIT$<>"" THEN GOSUB 1930
1540 WEND
1550 CLOSE
1560 PRINT
1570 IF ERASEOLD THEN KILL OLDNAME$ ELSE 1590
1580   PRINT"Erasing ";OLDNAME$
1590 IF RENAMECMD THEN NAME CMDNAME$ AS OLDNAME$ ELSE 1610
1600   PRINT"Changing ";CMDNAME$;" to ";OLDNAME$
1610 IF OVERWRITE$="Y" OR OVERWRITE$="y" THEN KILL CMDNAME$ ELSE 1630
1620   PRINT"Erasing ";CMDNAME$
1630 NAME TMPNAME$ AS CMDNAME$:PRINT"Changing ";TMPNAME$;" to ";CMDNAME$
1640 PRINT
1650 INPUT"Are you finished";ANS$
1660 IF LEFT$(ANS$,1)<>"Y" AND LEFT$(ANS$,1)<>"y" THEN 210
1670 END
1680 CLOSE
1690 PRINT BL$
1700 PRINT"[]==============[] This file contains incorrect syntax for a";BL$
1710 PRINT"[]   ABORTING   [] dBASE II .CMD file.  All lines not between"
1720 PRINT"[]==============[] TEXT and ENDTEXT must begin with a reserved"
1730 PRINT"                   word , '*' (remark) or '&' (macro character)
1740 PRINT
1750 PRINT"The error was found on line";LINES;"of ";FULLNAME$;", it reads:"
1760 PRINT
1770 PRINT "'";TXT$;"'"
1780 PRINT
1790 KILL TMPNAME$
1800 GOTO 1670
1810 CLOSE
1820 PRINT BL$
1830 PRINT"****ABORTING**** This file contains characters with the 8th bit set!"
1840 PRINT BL$
1850 PRINT"The error was in line";LINES;"of ";FULLNAME$;", it reads:"
1860 PRINT
1870 PRINT"'";TXT$;"'"
1880 KILL TMPNAME$
1890 PRINT
1900 GOTO 1670
1910 '	The ^C and ^S handling only works with BASCOM, not the interpreter.
1920 PRINT
1930 IF QUIT$=CHR$(3) THEN CLOSE ELSE 1960
1940   PRINT BL$;"****ABORTING**** ^C entered from keyboard.  No files changed"
1950   GOTO 1670
1960 IF QUIT$=CHR$(19) THEN WHILE INKEY$="":WEND
1970 RETURN
1980 IF ERR=53 AND ERL=920 THEN CLOSE #3 ELSE 2020
1990   PRINT CLS$;STRING$(5,10)
2000   PRINT CHR$(34);FULLNAME$;CHR$(34);" not found - try again.";BL$
2010   RESUME 320
2020 IF ERR=53 AND ERL=730 THEN CLOSE #1:RESUME 920
2030 IF ERR=53 AND ERL=890 THEN CLOSE #2:RESUME 920
2040 IF ERR=53 AND ERL=110 THEN CLOSE #1 ELSE 2280
2050   PRINT STRING$(18,10)
2060   PRINT BL$;"CLS.DAT, the clear screen data file, not found."
2070   PRINT"Please enter your clear screen sequence"
2080   PRINT"one byte at a time in Decimal numbers.  End your"
2090   PRINT"entries with a <RETURN> to generate CLS.DAT"
2100   PRINT
2110   FOR I=1 TO 9
2120     PRINT"Clear Screen character";I;
2130     LINE INPUT C$
2140     IF C$="" AND I>1 THEN 2230
2150     IF C$="" THEN 2120
2160     IF LEN(C$)>3 THEN 2120
2170     FOR J=1 TO LEN(C$)
2180       IF ASC(MID$(C$,J,1))<48 OR ASC(MID$(C$,J,1))>57 THEN PRINT BL$;

           "Whole decimal numbers only.":GOTO 2120
2190     NEXT J
2200     IF I>1 THEN CLR$=CLR$+CHR$(13)+CHR$(10)
2210     CLR$=CLR$+C$
2220   NEXT I
2230   PRINT"Writing CLS.DAT";
2240   OPEN "O",#1,"CLS.DAT"
2250   PRINT #1,CLR$
2260   CLOSE #1
2270   RESUME 100
2280 IF ERR=53 AND ERL=360 THEN PRINT CLS$;STRING$(5,10); ELSE 2310
2290   PRINT BL$;"The Help file, ENCODE.HLP, is not on this disk!";BL$
2300   RESUME 320
2310 IF ERR=64 THEN CLOSE ELSE 2350
2320   PRINT CLS$;STRING$(5,10)
2330   PRINT BL$;CHR$(34);FULLNAME$;CHR$(34);" is a bad file name - try again."
2340   RESUME 320
2350 ON ERROR GOTO 0
2360 DATA "IF",2,"ELSE",4,"ENDIF",5,"DO",2,"ENDDO",5,"CASE",4,"OTHERWISE",9
2370 DATA "ENDCASE",7,"DO WHILE",8,"DO CASE",7,"STORE",5,"?",1,"RELEASE",7
2380 DATA "RETURN",6,"SELECT",6,"@",1,"ACCEPT",6,"APPEND",6,"BROWSE",6,"CALL",4
2390 DATA "CANCEL",6,"CHANGE",6,"CLEAR",5,"COPY",4,"COUNT",5,"CREATE",6
2400 DATA "DELETE",6,"DISPLAY",7,"CONTINUE",8,"EDIT",4,"EJECT",5,"ERASE",5
2410 DATA "GO",2,"FIND",4,"HELP",4,"INDEX",5,"INPUT",5,"INSERT",6,"JOIN",4
2420 DATA "LIST",4,"LOAD",4,"LOCATE",6,"LOOP",4,"MODIFY",6,"PACK",4,"POKE",4
2430 DATA "QUIT",4,"READ",4,"RECALL",6,"REINDEX",7,"REMARK",6,"RENAME",6
2440 DATA "REPLACE",7,"REPORT",6,"RESET",5,"RESTORE",7,"SAVE",4,"SET",3
2450 DATA "SKIP",4,"SORT",4,"SUM",3,"TEXT",4,"TOTAL",5,"UNLOCK",6,"UPDATE",6
2460 DATA "USE",3,"WAIT",4
,7,"SAVE",4,"SET",3
2450 DATA "SKIP",4,"SORT",4,"SU