10 '	DBSRC2.BAS Version 1.02 (C) Copyright 1985 by Merlin R. Null
20 '	To read or generate a source file from encoded dBASE II .CMD files
30 '	This program may not be sold seperately 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)
80 WIDTH LPRINT 255
90 ON ERROR GOTO 1410	'Used mostly to detect incorrect filename
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)
200 NEXT I
210 PRINT CLS$:PRINT
220 PRINT TAB(10)"DBSOURCE II   Version 1.02   -   3/1/85"
230 PRINT
240 PRINT TAB(10)"A variant of DBSOURCE for different encoding"
250 PRINT:PRINT
260 PRINT"Options:	P		Send output to Printer"
270 PRINT"		F		Send output to File"
280 PRINT"		N		No console output"
290 PRINT
300 PRINT"Examples:	B:FOO.CMD PN	Printer output only"
310 PRINT"		FOO.CMD F	Output to file and console"
320 PRINT"		A:		Displays directory of A:"
330 PRINT"		?		Read the HELP file"
340 PRINT"		<RET>		Redisplays this screen"
350 PRINT:PRINT
360 PRINT		'return here after directory call
370 LINE INPUT"Filename.CMD or Drive:? ";NF$
380 CONOFF=0:LINEPRINT=0:WRITESRC=0:OPTFLAG=0:NFLEN=0:FULLNAME$=""
390 IF NF$="" THEN 210			'Redisplay start screen
400 IF NF$="?" THEN OPEN "I",#1,"DBSOURCE.HLP" ELSE 530
410   PRINT CLS$
420   FOR LINES=1 TO 20
430     IF EOF(1) THEN 480 ELSE LINE INPUT #1,HELP$
440     PRINT HELP$
450   NEXT LINES
460   PRINT
470   PRINT TAB(7)"<Press any key to continue reading help file>"
480   PRINT TAB(11)"Press <ESC> to return to DBSOURCE II ";
490   FINISHED$=INPUT$(1)
500   IF FINISHED$<>CHR$(27) THEN 410
510   CLOSE #1
520   GOTO 210
530 FOR I=1 TO LEN(NF$)		'Convert lower to upper case & detect options
540   BYTE$=MID$(NF$,I,1)
550   IF ASC(BYTE$)>96 AND ASC(BYTE$)<123 THEN BYTE$=CHR$(ASC(BYTE$)-32)
560   FULLNAME$=FULLNAME$+BYTE$
570   IF BYTE$=" " THEN OPTFLAG=-1		'Flag start of options
580   IF NOT OPTFLAG THEN 620
590   IF BYTE$="P" THEN LINEPRINT=-1		'Detect print option
600   IF BYTE$="F" THEN WRITESRC=-1		'Detect file option
610   IF BYTE$="N" THEN CONOFF=-1 		'Detect console off
620   IF NFLEN THEN 640
630   IF BYTE$="." THEN NFLEN=I+3		'Find filename length
640 NEXT I
650 IF CONOFF AND NOT LINEPRINT AND NOT WRITESRC THEN PRINT CLS$; ELSE 700
660   PRINT STRING$(5,10)
670   PRINT"N option may not be selected alone, only as NF or PN - try again.";
680   PRINT BL$
690   GOTO 360
700 IF NFLEN>3 THEN FULLNAME$=LEFT$(FULLNAME$,NFLEN)   'Remove extra charcters
710 IF MID$(FULLNAME$,2,1)=";" THEN MID$(FULLNAME$,2,1)=":"
720 IF LEN(FULLNAME$)=2 AND MID$(FULLNAME$,2,1)=":" THEN

      DIR$=LEFT$(FULLNAME$,1)+":*.*" ELSE 760
730   PRINT CLS$:PRINT"Directory of drive ";LEFT$(DIR$,2)
740   FILES DIR$
750   GOTO 360
760 IF RIGHT$(FULLNAME$,3)<>"CMD" THEN PRINT CLS$;STRING$(5,10) ELSE 800
770   PRINT BL$;CHR$(34);FULLNAME$;CHR$(34);
780   PRINT" is not a dBASE II command file - try again."
790   GOTO 360
800 FILENAME$=LEFT$(FULLNAME$,NFLEN-3)	'Remove extension
810 IF NOT WRITESRC THEN 1040
820 TMPNAME$=FILENAME$+"TMP"
830 SRCNAME$=FILENAME$+"SRC"
840 BAKNAME$=FILENAME$+"BAK"
850 OPEN "I",#1,SRCNAME$	'See if <filename>.SRC exists
860 CLOSE #1			'Close, if found.  Else error trap gets it
870 PRINT CLS$;STRING$(8,10)
880 PRINT TAB(20)"[]=========[]"
890 PRINT TAB(20)"[] WARNING []"
900 PRINT TAB(20)"[]=========[]"
910 PRINT
920 PRINT SRCNAME$;" already exists!  A 'NO' here will cause the current "
930 PRINT SRCNAME$;" to be renamed to ";BAKNAME$
940 PRINT:PRINT
950 PRINT"Do you wish to overwrite ";SRCNAME$;" (Yes/No/Quit)";
960 INPUT OVERWRITE$
970 IF LEFT$(OVERWRITE$,1)="Q" OR LEFT$(OVERWRITE$,1)="q" THEN 1330
980 IF LEFT$(OVERWRITE$,1)="Y" OR LEFT$(OVERWRITE$,1)="y" THEN 1040
990 IF LEFT$(OVERWRITE$,1)<>"N" AND LEFT$(OVERWRITE$,1)<>"n" THEN 870
1000 RENAMESRC=-1		'Flag to rename old source file
1010 OPEN "I",#1,BAKNAME$	'See if <filename>.BAK exists
1020 CLOSE #1			'Close, if found.  Else error trap gets it 
1030 ERASEBAK=-1		'Flag to erase old backup
1040 OPEN "I",#2,FULLNAME$
1050 IF WRITESRC THEN OPEN "O",#3,TMPNAME$
1060 PRINT CLS$;TAB(20)"^S to pause  -  ^C to end"
1070 WHILE NOT EOF(2)
1080   LINE INPUT #2,TXT$
1090   PRN$=""
1100   FOR BYTE=1 TO LEN(TXT$)
1110     IF ASC(MID$(TXT$,BYTE,1))<128 THEN PRN$=PRN$+MID$(TXT$,BYTE,1):

         GOTO 1170
1120     IF BYTE>1 THEN 1160
1130     IF ASC(MID$(TXT$,BYTE,1))>127 AND ASC(MID$(TXT$,BYTE,1))<195 THEN

         PRN$=PRN$+TOKEN$(ASC(MID$(TXT$,BYTE,1))-127)
1140     IF LEN(TXT$)=1 THEN 1170
1150     PRN$=PRN$+" ":GOTO 1170
1160     IF ASC(MID$(TXT$,BYTE,1))>127 THEN PRN$=PRN$+

         CHR$(ASC(MID$(TXT$,BYTE,1))XOR 255)
1170   NEXT BYTE
1180   IF NOT CONOFF THEN PRINT PRN$
1190   IF LINEPRINT THEN LPRINT PRN$
1200   IF WRITESRC THEN PRINT #3, PRN$
1210   QUIT$=INKEY$
1220   IF QUIT$<>"" THEN GOSUB 1380
1230 WEND
1240 PRINT
1250 CLOSE
1260 IF NOT WRITESRC THEN 1330
1270 PRINT
1280 IF ERASEBAK THEN KILL BAKNAME$:PRINT"Erasing  ";BAKNAME$
1290 IF RENAMESRC THEN NAME SRCNAME$ AS BAKNAME$ ELSE 1310
1300 PRINT"Changing ";SRCNAME$;" to ";BAKNAME$
1310 IF LEFT$(OVERWRITE$,1)="Y" OR LEFT$(OVERWRITE$,1)="y" THEN

     KILL SRCNAME$:PRINT"Erasing  ";SRCNAME$
1320 NAME TMPNAME$ AS SRCNAME$:PRINT"Changing ";TMPNAME$;" to ";SRCNAME$
1330 PRINT
1340 INPUT"Are you finished";ANS$
1350 IF LEFT$(ANS$,1)<>"Y" AND LEFT$(ANS$,1)<>"y" THEN 210
1360 END
1370 'The following quit and hold routine is for BASCOM only
1380 IF QUIT$=CHR$(3) THEN 1360				'If ^C then end
1390 IF QUIT$=CHR$(19) THEN WHILE INKEY$="":WEND	'If ^S then hold
1400 RETURN
1410 IF ERR=53 AND ERL=850 THEN CLOSE #1:RESUME 1040
1420 IF ERR=53 AND ERL=1010 THEN CLOSE #1:RESUME 1040
1430 IF ERR=53 AND ERL=110 THEN CLOSE #1 ELSE 1670
1440   PRINT STRING$(18,10)
1450   PRINT BL$;"CLS.DAT, the clear screen data file, not found."
1460   PRINT"Please enter your clear screen sequence"
1470   PRINT"one byte at a time in Decimal numbers.  End your"
1480   PRINT"entries with a <RETURN> to generate CLS.DAT"
1490   PRINT
1500   FOR I=1 TO 9
1510     PRINT"Clear Screen character";I;
1520     LINE INPUT C$
1530     IF C$="" AND I>1 THEN 1620
1540     IF C$="" THEN 1510
1550     IF LEN(C$)>3 THEN 1510
1560     FOR J=1 TO LEN(C$)
1570       IF ASC(MID$(C$,J,1))<48 OR ASC(MID$(C$,J,1))>57 THEN PRINT BL$;

           "Whole decimal numbers only.":GOTO 1510
1580     NEXT J
1590     IF I>1 THEN CLR$=CLR$+CHR$(13)+CHR$(10)
1600     CLR$=CLR$+C$
1610   NEXT I
1620   PRINT"Writing CLS.DAT";
1630   OPEN "O",#1,"CLS.DAT"
1640   PRINT #1,CLR$
1650   CLOSE #1
1660   RESUME 110
1670 IF ERR=64 THEN CLOSE ELSE 1710
1680   PRINT CLS$;STRING$(5,10)
1690   PRINT BL$;CHR$(34);FULLNAME$;CHR$(34);" is a bad file name - try again."
1700   RESUME 360
1710 IF ERR=53 AND ERL=1040 THEN CLOSE #2 ELSE 1750
1720   PRINT CLS$;STRING$(5,10)
1730   PRINT BL$;CHR$(34);FULLNAME$;CHR$(34);" not found - try again."
1740   RESUME 360
1750 IF ERR=53 AND ERL=400 THEN  CLOSE #1 ELSE 1790
1760   PRINT CLS$;STRING$(5,10)
1770   PRINT BL$;"The Help file, DBSOURCE.HLP, is missing from this disk!";BL$
1780   RESUME 360
1790 ON ERROR GOTO 0
1800 'For this variant of DBSOURCE, INDEX and INPUT have been exchanged,
1810 'so have USE and UPDATE.  HELP was removed and placed at the end of
1820 'the table.
1830 DATA "IF","ELSE","ENDIF","DO","ENDDO","CASE","OTHERWISE","ENDCASE"
1840 DATA "DO WHILE","DO CASE","STORE","?","RELEASE","RETURN","SELECT","@"
1850 DATA "ACCEPT","APPEND","BROWSE","CALL","CANCEL","CHANGE","CLEAR","COPY"
1860 DATA "COUNT","CREATE","DELETE","DISPLAY","CONTINUE","EDIT","EJECT","ERASE"
1870 DATA "GOTO","FIND",INPUT","INDEX","INSERT","JOIN","LIST","LOAD"
1880 DATA "LOCATE","LOOP","MODIFY","PACK","POKE","QUIT","READ","RECALL"
1890 DATA "REINDEX","REMARK","RENAME","REPLACE","REPORT","RESET","RESTORE"
1900 DATA "SAVE","SET","SKIP","SORT","SUM","TEXT","TOTAL","UNLOCK","USE"
1910 DATA "UPDATE","WAIT","HELP"
"RESET","RESTORE"
1900 DATA "SAVE","SET","SKIP","SORT","SUM","TEXT","TOT