home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / DATABASE / DATA206.LBR / DATA206.BZS / DATA206.BAS
BASIC Source File  |  2000-06-30  |  17KB  |  344 lines
  1. 10 REM ****
  2. 20 REM DATA.BAS, Lee R. Bradley, 11/23/86
  3. 30 REM ****
  4. 40 REM This program allows you to add, change, delete, find, sort, list
  5. 50 REM and print records in a file.  On line help is available if 
  6. 60 REM DATA.DOC is on the A: disk.  You may switch to a different
  7. 70 REM database file and/or create new ones.  The update functions
  8. 80 REM are available if you know the password associated with the
  9. 90 REM database.  Database files may have up to 100 records and up to
  10. 100 REM 18 fields (lines) per record.  The first record of a database file 
  11. 110 REM holds the string "DATA2.DAT", the number of records, the number of
  12. 120 REM fields and an encrypted password.  The second record holds
  13. 130 REM field descriptors.  The remaining records hold the data.  
  14. 140 REM Data fields hold strings.  When you create a new database
  15. 150 REM by switching to a non-existant name.DAT file, update access
  16. 160 REM to it is available via the program assigned password PASSWORD.
  17. 170 REM ****
  18. 180 DIM FL$(18,100)             : REM The array which holds the database
  19. 190 ON ERROR GOTO 2650
  20. 200 PRINT : PRINT "DATA.BAS, v2.06" : PRINT
  21. 210 IF FT$ = "" THEN FT$ = "NO" : F$ = "MESSAGES" : GOSUB 1110 : GOTO 230
  22. 220 GOSUB 1020  : REM Load data
  23. 230 GOSUB 610                   : REM Clear the screen
  24. 240 PRINT
  25. 250 PRINT "                   DATA.BAS, v2.06              "
  26. 260 PRINT "         Copyright 1986 (c) by Lee R. Bradley   "
  27. 270 PRINT
  28. 280 PRINT "         The current database is " F$+".DAT.    "
  29. 290 PRINT "         Record count is " COUNT-MARKED ".      "
  30. 300 PRINT "         There are " FLNUM " fields per record. "
  31. 310 PRINT
  32. 320 IF F$ = "MESSAGES" THEN EM$ = "ON" : REM Special treatment
  33. 330 IF EM$ = "ON" THEN US$ = "[P] rint, [A] dd, [C] hange, [D] elete"
  34. 340 IF EM$= "NO" OR EM$ = "" THEN US$ = "[U] pdate access"    
  35. 350 PRINT "[H] elp, [S] ort, [L] ist, [F] ind, s [W] itch database"
  36. 360 MS$ = "[R] ead specific record "
  37. 370 PRINT MS$
  38. 380 PRINT US$
  39. 390 PRINT "[Q] uit"
  40. 400 PRINT
  41. 410 PRINT "Command ... "; : C$ = INPUT$(1) : REM Get the command
  42. 420 WK$ = C$ : GOSUB 3100 : C$ = WK$     : REM Upper case the command
  43. 430 GOSUB 610                            : REM Clear the screen
  44. 440 IF C$ = "H" OR C$ = "?" THEN GOSUB 2820               : REM Help
  45. 450 IF C$ = "S"             THEN GOSUB 1980               : REM Sort
  46. 460 IF C$ = "L"             THEN GOSUB 1710               : REM List
  47. 470 IF C$ = "F"             THEN GOSUB 1340               : REM Find
  48. 480 IF C$ = "W"             THEN GOSUB 2490 : GOTO 220    : REM Which 
  49. 490 IF C$ = "Q"             THEN GOSUB 2490 : SYSTEM      : REM Quit
  50. 500 IF C$ <> "R" THEN 530     
  51. 510 INPUT "What is the number of the record you want to read ";I
  52. 520 GOSUB 1400                                            : REM Read specific
  53. 530 IF EM$ = "ON" THEN 560                                : REM Permit update
  54. 540 IF C$ = "U"             THEN GOSUB 3290               : REM Update access
  55. 550 GOTO 310                                              : REM Loop back    
  56. 560 IF C$ = "P"             THEN GOSUB 2930               : REM Print
  57. 570 IF C$ = "A"             THEN GOSUB 690                : REM Add
  58. 580 IF C$ = "C"             THEN GOSUB 1340               : REM Change
  59. 590 IF C$ = "D"             THEN GOSUB 1880               : REM Delete
  60. 600 GOTO 310                                              : REM Loop back
  61. 610 REM **** Clear screen
  62. 620 IF KP$ <> "" THEN 660 
  63. 630 PRINT : PRINT "Running an ADM3A compatible terminal ? "; 
  64. 640 YN$=INPUT$(1)
  65. 650 IF YN$ = "Y" OR YN$ = "y" THEN KP$ = "ON" ELSE KP$ = "NO"
  66. 660 IF KP$ = "ON" THEN PRINT CHR$(26) : RETURN            : REM True clear
  67. 670 PRINT
  68. 680 RETURN
  69. 690 REM **** Add record
  70. 700 PRINT
  71. 710 FOR J = 1 TO FLNUM 
  72. 720 IF COUNT = 0 THEN PRINT "Input field description "J; : GOTO 770
  73. 730 IF J > 1 THEN 760
  74. 740 PRINT "          ";
  75. 750 PRINT "<"; : FOR W = 1 TO 65 : PRINT "-"; : NEXT W : PRINT ">"
  76. 760 PRINT FL$(J,1) + " ";:FOR W = LEN(FL$(J,1))+1 TO 10 : PRINT " "; :NEXT W
  77. 770 LINE INPUT FL$                       : REM Get string
  78. 780 IF LEN(FL$) <= 9 OR COUNT > 0 THEN 800
  79. 790 PRINT "Keep descriptions under 10 characters please ...": GOTO 720
  80. 800 IF LEN(FL$) <= 65 THEN 820
  81. 810 PRINT "Keep lines under 65 characters please ... " : GOTO 760
  82. 820 IF LEN(FL$) = 0 THEN 940             : REM Refuse null input
  83. 830 IF J > 1 THEN 890                    : REM Avoid blank first lines
  84. 840 IF FL$ = "." THEN 880
  85. 850 FOR W = 1 TO LEN(FL$)
  86. 860 IF MID$(FL$,W,1) <> " " THEN 890
  87. 870 NEXT W
  88. 880 PRINT "First field should be non-blank." : GOTO 730
  89. 890 IF FL$ <> "." THEN 960     
  90. 900 FOR J1 = J TO FLNUM
  91. 910 FL$(J1,COUNT+1) = "."
  92. 920 NEXT J1
  93. 930 GOTO 980
  94. 940 PRINT "Enter non-null value or a period (.) to quit."
  95. 950 GOTO 720
  96. 960 FL$(J,COUNT+1) = FL$                 : REM Post data into array
  97. 970 NEXT J
  98. 980 PRINT : PRINT "Added."               : REM Tell 'em
  99. 990 COUNT = COUNT + 1                    : REM Update record pointer
  100. 1000 GOSUB 2440                           : REM Pause
  101. 1010 RETURN
  102. 1020 REM **** Open and load the database
  103. 1030 PRINT : PRINT "Welcome (back) to DATA.BAS !!!" : PRINT
  104. 1040 PRINT "Available database files are shown below " : PRINT
  105. 1050 FILES "A:*.DAT" : PRINT : PRINT      : REM Show directory
  106. 1060 FOLD$ = F$                           : REM Save old name
  107. 1070 INPUT "Enter the first name of an existing or new database "; F$
  108. 1080 IF LEN(F$) > 8 THEN 1070              : REM Avoid illegal name
  109. 1090 WK$ = F$ : GOSUB 3100 : F$ = WK$     : REM Upper case it
  110. 1100 IF LEN(F$) = 0 THEN 1070              : REM Reject nulls
  111. 1110 REM **** Entry point for use by sort logic
  112. 1120 OPEN "I",1,"A:" + F$ + ".DAT"        : REM Open the database
  113. 1130 INPUT #1,HD$                         : REM Header must be "DATA2.DAT"
  114. 1140 IF HD$ = "DATA2.DAT" THEN 1160
  115. 1150 PRINT "This is not a valid database file!!" : SYSTEM
  116. 1160 PRINT
  117. 1170 INPUT #1,COUNT                        : REM Read record count,
  118. 1180 INPUT #1,FLNUM                        : REM number of fields/record
  119. 1190 INPUT #1,EPW$                         : REM and encrypted password.
  120. 1200 FOR I = 1 TO COUNT                   : REM Now get descriptors and
  121. 1210 FOR J = 1 TO FLNUM                   : REM data into RAM
  122. 1220 LINE INPUT #1,FL$(J,I)               : REM Allow commas (,)
  123. 1230 NEXT J
  124. 1240 IF I > 1 THEN  PRINT "Record " I " concerns " FL$(1,I) "."
  125. 1250 NEXT I
  126. 1260 BF = FRE("")                         : REM Garbage collect
  127. 1270 PRINT 
  128. 1280 IF BF >= 1000 THEN 1300
  129. 1290 PRINT "Sorry, but I'm about out of string space ..." : SYSTEM 
  130. 1300 GOSUB 2440                           : REM Pause
  131. 1310 IF SS$ = "ON" THEN SS$ = "NO" : RETURN  : REM Go back to sort logic
  132. 1320 EM$ = "NO"                           : REM Turn off extended menu
  133. 1330 RETURN
  134. 1340 REM **** Find/Change
  135. 1350 PRINT
  136. 1360 FOR J = 1 TO FLNUM                   : REM Print descriptors 
  137. 1370 PRINT J; FL$(J,1) : NEXT J : PRINT 
  138. 1380 PRINT "Field # to search ( 1 ..";FLNUM;") "; : INPUT "",N
  139. 1390 GOSUB 2200                           : REM Locate record
  140. 1400 REM **** Alternate entry point
  141. 1410 IF I > COUNT THEN RETURN             : REM Return on no match
  142. 1420 UN$ = "Un"                           : REM Assume unchanged
  143. 1430 PRINT
  144. 1440 FOR J = 1 TO FLNUM
  145. 1450 PRINT J;FL$(J,1);                    : REM Print descriptors
  146. 1460 FOR Q = LEN(FL$(J,1)) TO 9           : REM Pad with blanks 
  147. 1470 PRINT " "; : NEXT Q
  148. 1480 IF J < 10 THEN PRINT " ";            : REM Just to be tidy
  149. 1490 PRINT FL$(J,I)                       : REM Show line        
  150. 1500 NEXT J
  151. 1510 PRINT
  152. 1520 IF EM$ = "ON" THEN 1540              : REM If allowed, permit update
  153. 1530 GOSUB 2440 : RETURN                  : REM Else pause and return
  154. 1540 PRINT "Field # to change ( 1 ..";FLNUM;") or 0 to end "; : INPUT "",F
  155. 1550 IF F = 0 THEN 1690
  156. 1560 PRINT FL$(F,I)                       : REM Show original
  157. 1570 LINE INPUT "New value ",FL$          : REM Ask for replacement
  158. 1580 IF LEN(FL$) > 65 THEN PRINT "Use 65 or fewer characters." : GOTO 1570
  159. 1590 IF LEN(FL$) > 0 THEN 1670            : REM Insist non-null
  160. 1600 PRINT "Empty values are not permitted !"
  161. 1610 GOTO 1570
  162. 1620 IF F > 1 THEN 1670
  163. 1630 FOR W = 1 TO LEN(FL$)
  164. 1640 IF MID$(FL$,W,1) <> " " THEN 1670
  165. 1650 NEXT W
  166. 1660 PRINT "First field must be non-blank." : GOTO 1570
  167. 1670 FL$(F,I) = FL$ : UN$ = ""            : REM Post update
  168. 1680 GOTO 1540                            : REM Loop for more changes
  169. 1690 PRINT : PRINT "Record " I " " + UN$ + "changed."
  170. 1700 GOSUB 2440 : RETURN                  : REM Pause and return
  171. 1710 REM **** List
  172. 1720 PRINT : I1 = 1                       : REM I1 tracks lines listed
  173. 1730 FOR I = 2 TO COUNT                   : REM Skip descriptor record
  174. 1740 IF FL$(1,I) = "*" THEN 1850          : REM Skip deleted
  175. 1750 PRINT "Record " I
  176. 1760 FOR J = 1 TO FLNUM 
  177. 1770 IF FL$(J,I) = "." THEN 1800          : REM Skip . fields
  178. 1780 PRINT FL$(J,1) + " " + FL$(J,I) : I1 = I1 + 1 : REM List it
  179. 1790 NEXT J
  180. 1800 PRINT
  181. 1810 REM Next line causes pauses between records
  182. 1820 IF I1 < 22 - (FLNUM + 1) THEN 1840
  183. 1830 GOSUB 2440 : PRINT : I1 = 1
  184. 1840 IF A$ = CHR$(27) THEN A$ = ""       : RETURN : REM Watch for Esc
  185. 1850 NEXT I
  186. 1860 IF I1 <> 1 THEN GOSUB 2440
  187. 1870 RETURN
  188. 1880 REM **** Delete
  189. 1890 FOR I = 1 TO FLNUM : PRINT I,FL$(I,1) : NEXT I
  190. 1900 PRINT "Field # to search ( 1 ..";FLNUM;") ";:INPUT "",N
  191. 1910 IF N = 0 THEN 1900                  : REM Deny null input
  192. 1920 GOSUB 2200                          : REM Locate record
  193. 1930 IF I > COUNT THEN RETURN            : REM Could not locate
  194. 1940 FL$(1,I) = "*"                      : REM Mark for eventual deletion
  195. 1950 MARKED = MARKED + 1                 : REM Keep track of number deleted
  196. 1960 PRINT "Deleted."                    : REM Tell 'em
  197. 1970 GOSUB 2440 : RETURN                 : REM Pause and return
  198. 1980 REM **** Sort (modified bubble sort)
  199. 1990 PRINT "[A] scending or [D] escending " : AD$ = INPUT$(1)
  200. 2000 SS$ = "ON" : GOSUB 2490 : GOSUB 1110 : REM Remove the deleted 
  201. 2010 PRINT
  202. 2020 FOR J = 1 TO FLNUM
  203. 2030 PRINT J,FL$(J,1) : NEXT J : PRINT   : REM Print descriptors
  204. 2040 PRINT "Field to sort on ( 1 ..";FLNUM;")";
  205. 2050 INPUT " ",N
  206. 2060 FOR I = 2 TO COUNT - 1              : REM Leave descriptor in slot 1
  207. 2070 FOR K = I + 1 TO COUNT
  208. 2080 IF AD$ = "A" OR AD$ = "a" THEN 2110
  209. 2090 IF FL$(N,I) >= FL$(N,K) THEN 2160
  210. 2100 GOTO 2120
  211. 2110 IF FL$(N,I) <= FL$(N,K) THEN 2160
  212. 2120 REM Swap when necessary
  213. 2130 FOR J = 1 TO FLNUM
  214. 2140 TEMP$ = FL$(J,I) : FL$(J,I) = FL$(J,K) : FL$(J,K) = TEMP$
  215. 2150 NEXT J
  216. 2160 NEXT K
  217. 2170 NEXT I : PRINT "Records sorted."
  218. 2180 GOSUB 2440                             : REM Pause
  219. 2190 RETURN
  220. 2200 REM **** Locate via all or part of field
  221. 2210 INPUT "Enter all or any part of field's value "; FL$
  222. 2220 IF LEN(FL$) = 0 THEN 2210              : REM Deny null input
  223. 2230 WK$ = FL$                              : REM Upper case it
  224. 2240 GOSUB 3100 : W1$ = WK$                 : REM And save
  225. 2250 IF C$ = "D" THEN S = 2 ELSE S = 1      : REM Don't delete descriptor 
  226. 2260 FOR I = S TO COUNT                     : REM Search database
  227. 2270 WK$ = FL$(N,I)                         : REM Upper case it too
  228. 2280 GOSUB 3100 : W2$ = WK$                 : REM And save
  229. 2290 FOR Q = 1 TO LEN(W2$) - LEN(W1$) + 1   : REM Scan field for match
  230. 2300 IF W1$ <> MID$(W2$,Q,LEN(W1$)) THEN 2330  
  231. 2310 IF FL$(1,I) = "*" THEN 2330            : REM Skip no hits and deleted
  232. 2320 GOTO 2350                              : REM Got a hit !
  233. 2330 NEXT Q 
  234. 2340 GOTO  2410                             : REM Keep lookin
  235. 2350 PRINT FL$(N,I)                         : REM Show matching field
  236. 2360 PRINT "Continue search ? "; 
  237. 2370 YN$=INPUT$(1)                          : REM See if they want more
  238. 2380 IF YN$ = "Y" OR YN$ = "y" THEN 2400    : REM And continue if so
  239. 2390 GOSUB 610 : PRINT : RETURN             : REM Else return
  240. 2400 PRINT
  241. 2410 NEXT I
  242. 2420 PRINT: PRINT "Record not found."       : REM Announce failure
  243. 2430 GOSUB 2440 : RETURN                    : REM Pause and return
  244. 2440 REM **** Pause
  245. 2450 PRINT "Any key (Esc to return) "
  246. 2460 A$=INPUT$(1)
  247. 2470 GOSUB 610                             : REM Clear screen
  248. 2480 RETURN
  249. 2490 REM **** Quit (after rewriting current database) 
  250. 2500 CLOSE #1                            : REM Close file
  251. 2510 OPEN "O",1,"A:" + F$ + ".DAT"       : REM Open for output
  252. 2520 REM Next line puts out header record which contains
  253. 2530 REM id string, non-deleted record count, fields per record and
  254. 2540 REM encrypted password
  255. 2550 PRINT #1,"DATA2.DAT,",COUNT-MARKED,FLNUM,EPW$
  256. 2560 FOR I = 1 TO COUNT
  257. 2570 IF FL$(1,I) = "*" THEN 2610         : REM Skip deleted records
  258. 2580 FOR J = 1 TO FLNUM                  : REM Write the records
  259. 2590 PRINT #1,FL$(J,I)
  260. 2600 NEXT J
  261. 2610 NEXT I
  262. 2620 CLOSE #1 : MARKED = 0
  263. 2630 PRINT : PRINT F$ + ".DAT updated."
  264. 2640 RETURN
  265. 2650 REM **** Error handler 
  266. 2660 IF ERR = 53 THEN GOTO 2710          : REM No such file
  267. 2670 IF ERR = 62 THEN RESUME 2900        : REM Read past end of help file
  268. 2680 PRINT "Error number " ERR           : REM Announce all other errors
  269. 2690 PRINT "Error line   " ERL
  270. 2700 GOSUB 2440 : RESUME 230             : REM Pause and return to menu
  271. 2710 IF H$ = "ON" THEN RESUME 2900       : REM Help file missing
  272. 2720 PRINT : PRINT F$ " is  a new file."  : REM User wants a new one
  273. 2730 IF F$ = "MESSAGES" THEN 2780
  274. 2740 PRINT "Do you want to create it ? "; : YN$ = INPUT$(1)
  275. 2750 IF YN$ = "Y" OR YN$ ="y" THEN 2780
  276. 2760 F$ = FOLD$                          : REM Restore old name
  277. 2770 CLOSE #1 : PRINT : RESUME 1040
  278. 2780 PRINT : INPUT "Fields/record (1..18) ";FLNUM : REM Get field #
  279. 2790 EPW$ = "ESPXTTBQ"                   : REM Set encrypted password 
  280. 2800 COUNT = 0                           : REM and record count
  281. 2810 RESUME 230
  282. 2820 REM **** Help
  283. 2830 H$ = "ON"                           : REM Turn on help switch
  284. 2840 OPEN "I",2,"A:DATA.DOC"             : REM Open help file
  285. 2850 IF A$=CHR$(27) THEN A$="" : GOTO 2900
  286. 2860 LINE INPUT #2,LIN$                  : REM Read a line from help file
  287. 2870 IF LIN$ = ".pa" THEN GOSUB 2440     : REM Pause or
  288. 2880 IF LIN$ <> ".pa" THEN PRINT LIN$
  289. 2890 GOTO 2850                           : REM Loop 
  290. 2900 CLOSE #2 : PRINT : GOSUB 2440       : REM Close help
  291. 2910 H$ = "NO"                           : REM Turn off help switch
  292. 2920 RETURN
  293. 2930 REM **** Print
  294. 2940 PRINT "Printer on line and positioned correctly ? "; : YN$ = INPUT$(1)
  295. 2950 IF YN$ <> "Y" AND YN$ <> "y" THEN PRINT : RETURN  : REM Permit bail out
  296. 2960 I1 = 0                              : REM To track lines printed
  297. 2970 FOR I = 1 TO COUNT
  298. 2980 IF FL$(1,I) = "*" THEN 3070         : REM Skip deleted
  299. 2990 FOR J = 1 TO FLNUM
  300. 3000 LPRINT FL$(J,I)                     : REM Print it
  301. 3010 NEXT J
  302. 3020 LPRINT
  303. 3030 I1 = I1 + FLNUM + 1
  304. 3040 IF I1 <= 60 - (FLNUM + 1) THEN 3070
  305. 3050 FOR W = I1 + 1 TO 66 : LPRINT : NEXT W  : REM To skip over crease
  306. 3060 I1 = 0
  307. 3070 NEXT I
  308. 3080 PRINT
  309. 3090 RETURN
  310. 3100 REM **** Upper case WK$
  311. 3110 W$ = ""
  312. 3120 FOR Q = 1 TO LEN(WK$)
  313. 3130 T$ = MID$(WK$,Q,1)
  314. 3140 IF T$ >= "a" THEN W$ = W$+CHR$(ASC(T$)-32) ELSE W$ = W$ + T$
  315. 3150 NEXT Q
  316. 3160 WK$ = W$
  317. 3170 RETURN
  318. 3180 REM **** Check access rights
  319. 3190 EM$= "NO"                          : REM Assume extended menu is not OK
  320. 3200 W$= ""                             : REM Null out work string
  321. 3210 FOR W = 1 TO LEN(EPW$)             : REM Decrypt encryted password
  322. 3220 W$= CHR$(ASC(MID$(EPW$,W,1))-1)+W$ : REM You figure it out ...
  323. 3230 NEXT W
  324. 3240 IF PW$ = W$ THEN EM$ = "ON" : RETURN : REM On match, extend the menu
  325. 3250 PRINT "Incorrect password. Sorry..."
  326. 3260 GOSUB 2440                         : REM Pause
  327. 3270 PW$=""
  328. 3280 RETURN
  329. 3290 REM **** Update access (optionally change password)
  330. 3300 INPUT "Enter current database's access password "; PW$
  331. 3310 GOSUB 3180                         : REM Check it
  332. 3320 IF EM$ <> "ON" THEN RETURN         : REM Deny if unknown
  333. 3330 PRINT "Want to change database's access password ? "; : YN$=INPUT$(1)
  334. 3340 IF YN$ = "Y" OR YN$= "y" THEN 3360 
  335. 3350 PRINT : RETURN
  336. 3360 INPUT "Enter new password ";PW$
  337. 3370 EPW$ = ""                          : REM Encrypt new one
  338. 3380 FOR W = 1 TO LEN(PW$)
  339. 3390 EPW$ = CHR$(ASC(MID$(PW$,W,1))+1) + EPW$  : REM You figure it out ...
  340. 3400 NEXT W
  341. 3410 RETURN
  342. 3420 END
  343. 1 TO LEN(PW$)
  344. 3390 EPW$ = CHR$(ASC(MID$(PW$,W,1))+