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