10 REM **** 20 REM DATA.BAS, Lee R. Bradley, 11/23/86 30 REM **** 40 REM This program allows you to add, change, delete, find, sort, list 50 REM and print records in a file. On line help is available if 60 REM DATA.DOC is on the A: disk. You may switch to a different 70 REM database file and/or create new ones. The update functions 80 REM are available if you know the password associated with the 90 REM database. Database files may have up to 100 records and up to 100 REM 18 fields (lines) per record. The first record of a database file 110 REM holds the string "DATA2.DAT", the number of records, the number of 120 REM fields and an encrypted password. The second record holds 130 REM field descriptors. The remaining records hold the data. 140 REM Data fields hold strings. When you create a new database 150 REM by switching to a non-existant name.DAT file, update access 160 REM to it is available via the program assigned password PASSWORD. 170 REM **** 180 DIM FL$(18,100) : REM The array which holds the database 190 ON ERROR GOTO 2650 200 PRINT : PRINT "DATA.BAS, v2.06" : PRINT 210 IF FT$ = "" THEN FT$ = "NO" : F$ = "MESSAGES" : GOSUB 1110 : GOTO 230 220 GOSUB 1020 : REM Load data 230 GOSUB 610 : REM Clear the screen 240 PRINT 250 PRINT " DATA.BAS, v2.06 " 260 PRINT " Copyright 1986 (c) by Lee R. Bradley " 270 PRINT 280 PRINT " The current database is " F$+".DAT. " 290 PRINT " Record count is " COUNT-MARKED ". " 300 PRINT " There are " FLNUM " fields per record. " 310 PRINT 320 IF F$ = "MESSAGES" THEN EM$ = "ON" : REM Special treatment 330 IF EM$ = "ON" THEN US$ = "[P] rint, [A] dd, [C] hange, [D] elete" 340 IF EM$= "NO" OR EM$ = "" THEN US$ = "[U] pdate access" 350 PRINT "[H] elp, [S] ort, [L] ist, [F] ind, s [W] itch database" 360 MS$ = "[R] ead specific record " 370 PRINT MS$ 380 PRINT US$ 390 PRINT "[Q] uit" 400 PRINT 410 PRINT "Command ... "; : C$ = INPUT$(1) : REM Get the command 420 WK$ = C$ : GOSUB 3100 : C$ = WK$ : REM Upper case the command 430 GOSUB 610 : REM Clear the screen 440 IF C$ = "H" OR C$ = "?" THEN GOSUB 2820 : REM Help 450 IF C$ = "S" THEN GOSUB 1980 : REM Sort 460 IF C$ = "L" THEN GOSUB 1710 : REM List 470 IF C$ = "F" THEN GOSUB 1340 : REM Find 480 IF C$ = "W" THEN GOSUB 2490 : GOTO 220 : REM Which 490 IF C$ = "Q" THEN GOSUB 2490 : SYSTEM : REM Quit 500 IF C$ <> "R" THEN 530 510 INPUT "What is the number of the record you want to read ";I 520 GOSUB 1400 : REM Read specific 530 IF EM$ = "ON" THEN 560 : REM Permit update 540 IF C$ = "U" THEN GOSUB 3290 : REM Update access 550 GOTO 310 : REM Loop back 560 IF C$ = "P" THEN GOSUB 2930 : REM Print 570 IF C$ = "A" THEN GOSUB 690 : REM Add 580 IF C$ = "C" THEN GOSUB 1340 : REM Change 590 IF C$ = "D" THEN GOSUB 1880 : REM Delete 600 GOTO 310 : REM Loop back 610 REM **** Clear screen 620 IF KP$ <> "" THEN 660 630 PRINT : PRINT "Running an ADM3A compatible terminal ? "; 640 YN$=INPUT$(1) 650 IF YN$ = "Y" OR YN$ = "y" THEN KP$ = "ON" ELSE KP$ = "NO" 660 IF KP$ = "ON" THEN PRINT CHR$(26) : RETURN : REM True clear 670 PRINT 680 RETURN 690 REM **** Add record 700 PRINT 710 FOR J = 1 TO FLNUM 720 IF COUNT = 0 THEN PRINT "Input field description "J; : GOTO 770 730 IF J > 1 THEN 760 740 PRINT " "; 750 PRINT "<"; : FOR W = 1 TO 65 : PRINT "-"; : NEXT W : PRINT ">" 760 PRINT FL$(J,1) + " ";:FOR W = LEN(FL$(J,1))+1 TO 10 : PRINT " "; :NEXT W 770 LINE INPUT FL$ : REM Get string 780 IF LEN(FL$) <= 9 OR COUNT > 0 THEN 800 790 PRINT "Keep descriptions under 10 characters please ...": GOTO 720 800 IF LEN(FL$) <= 65 THEN 820 810 PRINT "Keep lines under 65 characters please ... " : GOTO 760 820 IF LEN(FL$) = 0 THEN 940 : REM Refuse null input 830 IF J > 1 THEN 890 : REM Avoid blank first lines 840 IF FL$ = "." THEN 880 850 FOR W = 1 TO LEN(FL$) 860 IF MID$(FL$,W,1) <> " " THEN 890 870 NEXT W 880 PRINT "First field should be non-blank." : GOTO 730 890 IF FL$ <> "." THEN 960 900 FOR J1 = J TO FLNUM 910 FL$(J1,COUNT+1) = "." 920 NEXT J1 930 GOTO 980 940 PRINT "Enter non-null value or a period (.) to quit." 950 GOTO 720 960 FL$(J,COUNT+1) = FL$ : REM Post data into array 970 NEXT J 980 PRINT : PRINT "Added." : REM Tell 'em 990 COUNT = COUNT + 1 : REM Update record pointer 1000 GOSUB 2440 : REM Pause 1010 RETURN 1020 REM **** Open and load the database 1030 PRINT : PRINT "Welcome (back) to DATA.BAS !!!" : PRINT 1040 PRINT "Available database files are shown below " : PRINT 1050 FILES "A:*.DAT" : PRINT : PRINT : REM Show directory 1060 FOLD$ = F$ : REM Save old name 1070 INPUT "Enter the first name of an existing or new database "; F$ 1080 IF LEN(F$) > 8 THEN 1070 : REM Avoid illegal name 1090 WK$ = F$ : GOSUB 3100 : F$ = WK$ : REM Upper case it 1100 IF LEN(F$) = 0 THEN 1070 : REM Reject nulls 1110 REM **** Entry point for use by sort logic 1120 OPEN "I",1,"A:" + F$ + ".DAT" : REM Open the database 1130 INPUT #1,HD$ : REM Header must be "DATA2.DAT" 1140 IF HD$ = "DATA2.DAT" THEN 1160 1150 PRINT "This is not a valid database file!!" : SYSTEM 1160 PRINT 1170 INPUT #1,COUNT : REM Read record count, 1180 INPUT #1,FLNUM : REM number of fields/record 1190 INPUT #1,EPW$ : REM and encrypted password. 1200 FOR I = 1 TO COUNT : REM Now get descriptors and 1210 FOR J = 1 TO FLNUM : REM data into RAM 1220 LINE INPUT #1,FL$(J,I) : REM Allow commas (,) 1230 NEXT J 1240 IF I > 1 THEN PRINT "Record " I " concerns " FL$(1,I) "." 1250 NEXT I 1260 BF = FRE("") : REM Garbage collect 1270 PRINT 1280 IF BF >= 1000 THEN 1300 1290 PRINT "Sorry, but I'm about out of string space ..." : SYSTEM 1300 GOSUB 2440 : REM Pause 1310 IF SS$ = "ON" THEN SS$ = "NO" : RETURN : REM Go back to sort logic 1320 EM$ = "NO" : REM Turn off extended menu 1330 RETURN 1340 REM **** Find/Change 1350 PRINT 1360 FOR J = 1 TO FLNUM : REM Print descriptors 1370 PRINT J; FL$(J,1) : NEXT J : PRINT 1380 PRINT "Field # to search ( 1 ..";FLNUM;") "; : INPUT "",N 1390 GOSUB 2200 : REM Locate record 1400 REM **** Alternate entry point 1410 IF I > COUNT THEN RETURN : REM Return on no match 1420 UN$ = "Un" : REM Assume unchanged 1430 PRINT 1440 FOR J = 1 TO FLNUM 1450 PRINT J;FL$(J,1); : REM Print descriptors 1460 FOR Q = LEN(FL$(J,1)) TO 9 : REM Pad with blanks 1470 PRINT " "; : NEXT Q 1480 IF J < 10 THEN PRINT " "; : REM Just to be tidy 1490 PRINT FL$(J,I) : REM Show line 1500 NEXT J 1510 PRINT 1520 IF EM$ = "ON" THEN 1540 : REM If allowed, permit update 1530 GOSUB 2440 : RETURN : REM Else pause and return 1540 PRINT "Field # to change ( 1 ..";FLNUM;") or 0 to end "; : INPUT "",F 1550 IF F = 0 THEN 1690 1560 PRINT FL$(F,I) : REM Show original 1570 LINE INPUT "New value ",FL$ : REM Ask for replacement 1580 IF LEN(FL$) > 65 THEN PRINT "Use 65 or fewer characters." : GOTO 1570 1590 IF LEN(FL$) > 0 THEN 1670 : REM Insist non-null 1600 PRINT "Empty values are not permitted !" 1610 GOTO 1570 1620 IF F > 1 THEN 1670 1630 FOR W = 1 TO LEN(FL$) 1640 IF MID$(FL$,W,1) <> " " THEN 1670 1650 NEXT W 1660 PRINT "First field must be non-blank." : GOTO 1570 1670 FL$(F,I) = FL$ : UN$ = "" : REM Post update 1680 GOTO 1540 : REM Loop for more changes 1690 PRINT : PRINT "Record " I " " + UN$ + "changed." 1700 GOSUB 2440 : RETURN : REM Pause and return 1710 REM **** List 1720 PRINT : I1 = 1 : REM I1 tracks lines listed 1730 FOR I = 2 TO COUNT : REM Skip descriptor record 1740 IF FL$(1,I) = "*" THEN 1850 : REM Skip deleted 1750 PRINT "Record " I 1760 FOR J = 1 TO FLNUM 1770 IF FL$(J,I) = "." THEN 1800 : REM Skip . fields 1780 PRINT FL$(J,1) + " " + FL$(J,I) : I1 = I1 + 1 : REM List it 1790 NEXT J 1800 PRINT 1810 REM Next line causes pauses between records 1820 IF I1 < 22 - (FLNUM + 1) THEN 1840 1830 GOSUB 2440 : PRINT : I1 = 1 1840 IF A$ = CHR$(27) THEN A$ = "" : RETURN : REM Watch for Esc 1850 NEXT I 1860 IF I1 <> 1 THEN GOSUB 2440 1870 RETURN 1880 REM **** Delete 1890 FOR I = 1 TO FLNUM : PRINT I,FL$(I,1) : NEXT I 1900 PRINT "Field # to search ( 1 ..";FLNUM;") ";:INPUT "",N 1910 IF N = 0 THEN 1900 : REM Deny null input 1920 GOSUB 2200 : REM Locate record 1930 IF I > COUNT THEN RETURN : REM Could not locate 1940 FL$(1,I) = "*" : REM Mark for eventual deletion 1950 MARKED = MARKED + 1 : REM Keep track of number deleted 1960 PRINT "Deleted." : REM Tell 'em 1970 GOSUB 2440 : RETURN : REM Pause and return 1980 REM **** Sort (modified bubble sort) 1990 PRINT "[A] scending or [D] escending " : AD$ = INPUT$(1) 2000 SS$ = "ON" : GOSUB 2490 : GOSUB 1110 : REM Remove the deleted 2010 PRINT 2020 FOR J = 1 TO FLNUM 2030 PRINT J,FL$(J,1) : NEXT J : PRINT : REM Print descriptors 2040 PRINT "Field to sort on ( 1 ..";FLNUM;")"; 2050 INPUT " ",N 2060 FOR I = 2 TO COUNT - 1 : REM Leave descriptor in slot 1 2070 FOR K = I + 1 TO COUNT 2080 IF AD$ = "A" OR AD$ = "a" THEN 2110 2090 IF FL$(N,I) >= FL$(N,K) THEN 2160 2100 GOTO 2120 2110 IF FL$(N,I) <= FL$(N,K) THEN 2160 2120 REM Swap when necessary 2130 FOR J = 1 TO FLNUM 2140 TEMP$ = FL$(J,I) : FL$(J,I) = FL$(J,K) : FL$(J,K) = TEMP$ 2150 NEXT J 2160 NEXT K 2170 NEXT I : PRINT "Records sorted." 2180 GOSUB 2440 : REM Pause 2190 RETURN 2200 REM **** Locate via all or part of field 2210 INPUT "Enter all or any part of field's value "; FL$ 2220 IF LEN(FL$) = 0 THEN 2210 : REM Deny null input 2230 WK$ = FL$ : REM Upper case it 2240 GOSUB 3100 : W1$ = WK$ : REM And save 2250 IF C$ = "D" THEN S = 2 ELSE S = 1 : REM Don't delete descriptor 2260 FOR I = S TO COUNT : REM Search database 2270 WK$ = FL$(N,I) : REM Upper case it too 2280 GOSUB 3100 : W2$ = WK$ : REM And save 2290 FOR Q = 1 TO LEN(W2$) - LEN(W1$) + 1 : REM Scan field for match 2300 IF W1$ <> MID$(W2$,Q,LEN(W1$)) THEN 2330 2310 IF FL$(1,I) = "*" THEN 2330 : REM Skip no hits and deleted 2320 GOTO 2350 : REM Got a hit ! 2330 NEXT Q 2340 GOTO 2410 : REM Keep lookin 2350 PRINT FL$(N,I) : REM Show matching field 2360 PRINT "Continue search ? "; 2370 YN$=INPUT$(1) : REM See if they want more 2380 IF YN$ = "Y" OR YN$ = "y" THEN 2400 : REM And continue if so 2390 GOSUB 610 : PRINT : RETURN : REM Else return 2400 PRINT 2410 NEXT I 2420 PRINT: PRINT "Record not found." : REM Announce failure 2430 GOSUB 2440 : RETURN : REM Pause and return 2440 REM **** Pause 2450 PRINT "Any key (Esc to return) " 2460 A$=INPUT$(1) 2470 GOSUB 610 : REM Clear screen 2480 RETURN 2490 REM **** Quit (after rewriting current database) 2500 CLOSE #1 : REM Close file 2510 OPEN "O",1,"A:" + F$ + ".DAT" : REM Open for output 2520 REM Next line puts out header record which contains 2530 REM id string, non-deleted record count, fields per record and 2540 REM encrypted password 2550 PRINT #1,"DATA2.DAT,",COUNT-MARKED,FLNUM,EPW$ 2560 FOR I = 1 TO COUNT 2570 IF FL$(1,I) = "*" THEN 2610 : REM Skip deleted records 2580 FOR J = 1 TO FLNUM : REM Write the records 2590 PRINT #1,FL$(J,I) 2600 NEXT J 2610 NEXT I 2620 CLOSE #1 : MARKED = 0 2630 PRINT : PRINT F$ + ".DAT updated." 2640 RETURN 2650 REM **** Error handler 2660 IF ERR = 53 THEN GOTO 2710 : REM No such file 2670 IF ERR = 62 THEN RESUME 2900 : REM Read past end of help file 2680 PRINT "Error number " ERR : REM Announce all other errors 2690 PRINT "Error line " ERL 2700 GOSUB 2440 : RESUME 230 : REM Pause and return to menu 2710 IF H$ = "ON" THEN RESUME 2900 : REM Help file missing 2720 PRINT : PRINT F$ " is a new file." : REM User wants a new one 2730 IF F$ = "MESSAGES" THEN 2780 2740 PRINT "Do you want to create it ? "; : YN$ = INPUT$(1) 2750 IF YN$ = "Y" OR YN$ ="y" THEN 2780 2760 F$ = FOLD$ : REM Restore old name 2770 CLOSE #1 : PRINT : RESUME 1040 2780 PRINT : INPUT "Fields/record (1..18) ";FLNUM : REM Get field # 2790 EPW$ = "ESPXTTBQ" : REM Set encrypted password 2800 COUNT = 0 : REM and record count 2810 RESUME 230 2820 REM **** Help 2830 H$ = "ON" : REM Turn on help switch 2840 OPEN "I",2,"A:DATA.DOC" : REM Open help file 2850 IF A$=CHR$(27) THEN A$="" : GOTO 2900 2860 LINE INPUT #2,LIN$ : REM Read a line from help file 2870 IF LIN$ = ".pa" THEN GOSUB 2440 : REM Pause or 2880 IF LIN$ <> ".pa" THEN PRINT LIN$ 2890 GOTO 2850 : REM Loop 2900 CLOSE #2 : PRINT : GOSUB 2440 : REM Close help 2910 H$ = "NO" : REM Turn off help switch 2920 RETURN 2930 REM **** Print 2940 PRINT "Printer on line and positioned correctly ? "; : YN$ = INPUT$(1) 2950 IF YN$ <> "Y" AND YN$ <> "y" THEN PRINT : RETURN : REM Permit bail out 2960 I1 = 0 : REM To track lines printed 2970 FOR I = 1 TO COUNT 2980 IF FL$(1,I) = "*" THEN 3070 : REM Skip deleted 2990 FOR J = 1 TO FLNUM 3000 LPRINT FL$(J,I) : REM Print it 3010 NEXT J 3020 LPRINT 3030 I1 = I1 + FLNUM + 1 3040 IF I1 <= 60 - (FLNUM + 1) THEN 3070 3050 FOR W = I1 + 1 TO 66 : LPRINT : NEXT W : REM To skip over crease 3060 I1 = 0 3070 NEXT I 3080 PRINT 3090 RETURN 3100 REM **** Upper case WK$ 3110 W$ = "" 3120 FOR Q = 1 TO LEN(WK$) 3130 T$ = MID$(WK$,Q,1) 3140 IF T$ >= "a" THEN W$ = W$+CHR$(ASC(T$)-32) ELSE W$ = W$ + T$ 3150 NEXT Q 3160 WK$ = W$ 3170 RETURN 3180 REM **** Check access rights 3190 EM$= "NO" : REM Assume extended menu is not OK 3200 W$= "" : REM Null out work string 3210 FOR W = 1 TO LEN(EPW$) : REM Decrypt encryted password 3220 W$= CHR$(ASC(MID$(EPW$,W,1))-1)+W$ : REM You figure it out ... 3230 NEXT W 3240 IF PW$ = W$ THEN EM$ = "ON" : RETURN : REM On match, extend the menu 3250 PRINT "Incorrect password. Sorry..." 3260 GOSUB 2440 : REM Pause 3270 PW$="" 3280 RETURN 3290 REM **** Update access (optionally change password) 3300 INPUT "Enter current database's access password "; PW$ 3310 GOSUB 3180 : REM Check it 3320 IF EM$ <> "ON" THEN RETURN : REM Deny if unknown 3330 PRINT "Want to change database's access password ? "; : YN$=INPUT$(1) 3340 IF YN$ = "Y" OR YN$= "y" THEN 3360 3350 PRINT : RETURN 3360 INPUT "Enter new password ";PW$ 3370 EPW$ = "" : REM Encrypt new one 3380 FOR W = 1 TO LEN(PW$) 3390 EPW$ = CHR$(ASC(MID$(PW$,W,1))+1) + EPW$ : REM You figure it out ... 3400 NEXT W 3410 RETURN 3420 END