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