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

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

         GOTO 1150
1100     IF BYTE>1 THEN 1140
1110     IF ASC(MID$(TXT$,BYTE,1))>127 AND ASC(MID$(TXT$,BYTE,1))<195 THEN

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

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

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

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