100 ! ISAM Sample Program 125 ! 150 ! This program is a simple example of how to handle ISAM files, both 175 ! primary and secondary. It simulates a very simple-minded mailing 200 ! list program, with the addresses keyed by both name and user 225 ! defined hash code. 250 ! 275 ! Define the Mailing List file record. 300 ! 325 MAP1 LABEL 350 MAP2 NAME,S,25 375 MAP2 ADDRESS,S,25 400 MAP2 STATE,S,2 425 MAP2 ZIP,S,5 450 MAP2 HASH,S,10 475 MAP1 FIELDS 500 MAP2 NEW'ADDRESS,S,25 525 MAP2 NEW'STATE,S,2 550 MAP2 NEW'ZIP,S,5 575 MAP2 NEW'HASH,S,10 600 MAP1 RECSIZE,F,6,67 ! Define record sizes. 625 MAP1 DUMMY'REC,X,67 650 MAP1 ORG'BUF,X,67 675 MAP1 NEW'BUF,X,67 700 MAP1 OLD'HASH,S,10 725 MAP1 SAV'HASH,S,10 750 MAP1 OLD'NAME,S,25 775 MAP1 NEW'NAME,S,25 800 ! Open the primary and secondary 825 ! index files. 850 ON ERROR GOTO ERR'TRAP 875 OPEN #100,"LABELS",INDEXED,RECSIZE,RELKEY1 900 OPEN #200,"HASH",INDEXED,RECSIZE,RELKEY1 925 PROMPT: 950 PRINT : FUNCTION = 0 975 INPUT "ENTER FUNCTION & (1=ADD,2=DELETE,3=INQUIRE,4=PRINT,5=CHANGE,99=END): ";FUNCTION 1000 ON FUNCTION GOTO & ADD'RECORD,DELETE'RECORD,INQUIRE'RECORD,PRINT'LABELS,CHANGE'RECORD 1025 IF FUNCTION=99 THEN GOTO END'IT 1050 GOTO PROMPT 1075 ADD'RECORD: 1100 INPUT "ENTER NAME: ";NAME 1125 INPUT "ENTER HASH: ";HASH 1150 NAME=NAME+SPACE(25-LEN(NAME)) ! Add trailing blanks to the keys. 1175 HASH=HASH+SPACE(10-LEN(HASH)) 1200 ISAM #100,1,NAME ! Look up name to verify that 1225 ! it is not a duplicate. 1250 IF ERF(100) = 0 & THEN PRINT "DUPLICATE NAME" : UNLOKR #100 : GOTO ADD'RECORD 1275 ! If ERF(100)=0, then ISAM 1300 ! found the key in the index file 1325 IF ERF(100) # 33 THEN GOTO ISAM'ERROR 1350 ISAM #200,1,HASH ! Verify that has is not a 1375 ! duplicate. 1400 IF ERF(200)=0 & THEN PRINT "DUPLICATE HASH" : UNLOKR #100 : GOTO ADD'RECORD 1425 IF ERF(200) # 33 THEN GOTO ISAM'ERROR 1450 ISAM #100,5,NAME ! Get free data record from 1475 ! primary file. 1500 IF ERF(100) # 0 THEN GOTO ISAM'ERROR 1525 WRITEL #100,SPACE(RECSIZE) ! Write blank record out 1550 ISAM #200,3,HASH ! Add key to secondary index file. 1575 IF ERF(200) # 0 THEN GOTO ISAM'ERROR 1600 ISAM #100,3,NAME ! Add Key to primary index file. 1625 IF ERF(100) # 0 THEN GOTO ISAM'ERROR 1650 INPUT "ENTER ADDRESS: ";ADDRESS 1675 INPUT "ENTER STATE: ";STATE 1700 INPUT "ENTER ZIP: ";ZIP 1725 ISAM #100,1,NAME 1750 IF ERF(100) = 33 THEN GOTO POST'ADD ! If deleted, add it back 1775 IF ERF(100) # 0 THEN GOTO ISAM'ERROR 1800 READL #100,DUMMY'REC : OLD'HASH=HASH 1825 CALL DEL'HASH : CALL ADD'HASH 1850 WRITE #100,LABEL 1875 GOTO PROMPT 1900 POST'ADD: 1925 ISAM #100,5,NAME 1950 IF ERF(100) # 0 THEN GOTO ISAM'ERROR 1975 WRITEL #100,LABEL : OLD'HASH=HASH 2000 CALL DEL'HASH : CALL ADD'HASH 2025 ISAM #100,3,NAME 2050 IF ERF(100) # 0 THEN GOTO ISAM'ERROR 2075 GOTO PROMPT 2100 DELETE'RECORD: 2125 INPUT "ENTER NAME: ";NAME 2150 NAME = NAME + SPACE(25-LEN(NAME)) 2175 ISAM #100,1,NAME ! Verify that the key exists. 2200 IF ERF(100)=33 & THEN PRINT "RECORD NOT FOUND" : UNLOKR #100 : GOTO PROMPT 2225 IF ERF(100) # 0 THEN GOTO ISAM'ERROR 2250 READ #100,LABEL : OLD'HASH=HASH 2275 PRINT "NAME ";NAME 2300 PRINT "ADDRESS ";ADDRESS 2325 PRINT "STATE ";STATE 2350 PRINT "ZIP ";ZIP : PRINT 2375 PRINT "Right Record? "; : INPUT YN$ 2400 IF UCS(YN$)[1;1] # "Y" THEN GOTO DELETE'RECORD 2425 ISAM #100,1,NAME 2450 IF ERF(100) = 33 THEN UNLOKR #100 : GOTO PROMPT 2475 IF ERF(100) # 0 THEN GOTO ISAM'ERROR 2500 READL #100,LABEL : PTR=RELKEY1 2525 ISAM #200,4,HASH ! Delete the key from secondary 2550 IF ERF(200)=33 THEN GOTO DEL'PRIM 2575 IF ((ERF(200) = 0) AND (RELKEY1 # PTR)) THEN & CALL ADD'HASH : GOTO DEL'PRIM 2600 IF ERF(200) # 0 THEN GOTO ISAM'ERROR 2625 DEL'PRIM: 2650 ISAM #100,4,NAME ! Delete the key from primary 2675 IF ERF(100) # 0 THEN GOTO ISAM'ERROR 2700 ISAM #100,6,NAME ! Delete the data record 2725 ! in data file. 2750 IF ERF(100) # 0 THEN GOTO ISAM'ERROR 2775 GOTO PROMPT 2800 INQUIRE'RECORD: 2825 INPUT "BY NAME (1) OR HASH (2): ";FUNCTION 2850 IF FUNCTION = 2 THEN GOTO BY'HASH 2875 INPUT "NAME: ";NAME 2900 NAME = NAME + SPACE(25-LEN(NAME)) 2925 ISAM #100,1,NAME ! Locate the reocrd 2950 IF ERF(100) = 33 & THEN PRINT "RECORD NOT FOUND" : UNLOKR #100 : GOTO PROMPT 2975 IF ERF(100) # 0 THEN GOTO ISAM'ERROR 3000 READ'RECORD: 3025 READ #100,LABEL ! Read the reocrd 3050 PRINT NAME,HASH 3075 PRINT ADDRESS,STATE,ZIP 3100 GOTO PROMPT 3125 BY'HASH: ! Locate record by hash 3150 INPUT "HASH: ";HASH 3175 HASH=HASH + SPACE(10-LEN(HASH)) 3200 LOCK #100 ! Lock primary index file 3225 ISAM #200,1,HASH 3250 IF ERF(200) = 33 & THEN PRINT "RECORD NOT FOUND" : UNLOKR #100 : GOTO PROMPT 3275 IF ERF(200) # 0 THEN GOTO ISAM'ERROR 3300 GOTO READ'RECORD 3325 PRINT'LABELS: 3350 NAME = SPACE(25) ! Read null key to get to front 3375 ISAM #100,1,NAME ! of file. 3400 IF (NOT ERF(100) = 33) AND (NOT ERF(100) = 0) THEN GOTO ISAM'ERROR 3425 UNLOKR #100 ! Release the index; ignore if found 3450 LOOP: 3525 ISAM #100,2,NAME 3550 IF ERF(100)=38 THEN UNLOKR #100 : GOTO PROMPT ! We hit end-of-file 3575 IF ERF(100) # 0 THEN GOTO ISAM'ERROR 3600 READ #100,LABEL ! unlocks index 3625 PRINT 3650 PRINT NAME,HASH 3675 PRINT ADDRESS,STATE,ZIP 3700 GOTO LOOP 3725 CHANGE'RECORD: 3750 INPUT "BY NAME (1) OR HASH (2) OR CHG PRIMARY (3): "; FUNCTION 3775 ON FUNCTION-1 GOTO BY'HASH'CHANGE,CHG'PRIMARY 3800 INPUT "NAME: ";NAME 3825 NAME = NAME + SPACE(25-LEN(NAME)) 3850 ISAM #100,1,NAME ! Locate the record 3875 IF ERF(100) = 33 & THEN PRINT "RECORD NOT FOUND" : UNLOKR #100 : GOTO PROMPT 3900 IF ERF(100) # 0 THEN GOTO ISAM'ERROR 3925 READ'RECORD'CHANGE: 3950 READ #100,LABEL : ORG'BUF=LABEL : OLD'HASH=HASH : PTR=RELKEY1 3975 PRINT NAME,HASH : NEW'HASH="" 4000 PRINT "ADDRESS= "+ADDRESS : NEW'ADDRESS="" 4025 INPUT "NEW'ADDRESS: ";NEW'ADDRESS 4050 IF LEN(NEW'ADDRESS) > 0 THEN ADDRESS=NEW'ADDRESS 4075 PRINT "STATE= "+STATE : NEW'STATE="" 4100 INPUT "NEW STATE =";NEW'STATE 4125 IF LEN(NEW'STATE) > 0 THEN STATE = NEW'STATE 4150 PRINT "ZIP = "+ZIP : NEW'ZIP="" 4175 INPUT "NEW ZIP =";NEW'ZIP 4200 IF LEN(NEW'ZIP) > 0 THEN ZIP=NEW'ZIP 4225 INPUT "NEW HASH= ";NEW'HASH 4250 IF LEN(NEW'HASH) > 0 THEN HASH=NEW'HASH+SPACE(10) 4275 ISAM #100,1,NAME 4300 IF ERF(100) = 33 THEN GOTO POST'ADD ! know secondary is gone also 4325 IF ERF(100) # 0 THEN GOTO ISAM'ERROR 4350 READL #100,NEW'BUF 4375 IF NEW'BUF # OLD'BUF THEN CALL MAK'CHG ! or UNLOKR #100 : GOTO PROMPT 4400 IF LEN(NEW'HASH) = 0 THEN GOTO WRT'IT 4425 PTR=RELKEY1 4450 CALL ADD'HASH 4475 IF PTR # RELKEY1 THEN UNLOKR #100 : & PRINT "Duplicate secondary " : GOTO CHANGE'RECORD 4500 ISAM #200,4,OLD'HASH 4525 IF ERF(200) = 33 THEN RELKEY1=PTR : GOTO WRT'IT 4550 IF ((ERF(200) = 0) AND (RELKEY1 # PTR)) THEN SAV'HASH=HASH : & HASH=OLD'HASH : CALL ADD'HASH : HASH=SAV'HASH : & RELKEY1=PTR : GOTO WRT'IT 4575 IF ERF(200) # 0 THEN GOTO ISAM'ERROR 4600 WRT'IT: 4625 WRITE #100,LABEL 4650 GOTO PROMPT 4675 ADD'HASH: 4700 ISAM #200,3,HASH 4725 IF ((NOT ERF(200)=34) AND (NOT ERF(200)=0)) THEN GOTO ISAM'ERROR 4750 RETURN 4775 DEL'HASH: 4800 PTR=RELKEY1 4825 ISAM #200,4,OLD'HASH 4850 IF ((NOT ERF(200)=33) AND (NOT ERF(200)=0)) THEN GOTO ISAM'ERROR 4875 RELKEY1 = PTR 4900 RETURN 4925 MAK'CHG: 4950 ! None of the fields in this record are quantitative. A change 4975 ! between the old and new buffers in this case is insignificant. 5000 ! Additionally, handling quantitative data updates is independent 5025 ! of techniques of multiple key accessess... 5050 RETURN 5075 BY'HASH'CHANGE: 5100 INPUT "HASH: ";HASH 5125 HASH=HASH+SPACE(10-LEN(HASH)) 5150 LOCK #100 5175 ISAM #200,1,HASH 5200 IF ERF(200) =33 & THEN PRINT "RECORD NOT FOUND" : UNLOKR #100 : GOTO PROMPT 5225 IF ERF(200) # 0 THEN GOTO ISAM'ERROR 5250 GOTO READ'RECORD'CHANGE 5275 END'IT: ! Be sure to close files 5300 CLOSE #100 ! before we exit! 5325 CLOSE #200 5350 END 5375 ISAM'ERROR: ! ERF(X) returned ISAM error 5400 PRINT "?FATAL ISAM ERROR" ! other than RECORD NOT FOUND 5425 PRINT "ISAM ERROR "+ERF(100)+"; SECONDARY: "+ERF(200) 5450 UNLOKR #100 5475 GOTO PROMPT 5500 ERR'TRAP: 5525 PRINT "Error= ";ERR(0);" on line ";ERR(1);" for file ";ERR(2) 5550 PRINT "Current ERF code on Primary ";ERF(100);" secondary: ";ERF(200) 5575 RESUME END'IT 5600 CHG'PRIMARY: 5625 INPUT "NAME: ";NAME 5650 NAME=NAME + SPACE(25-LEN(NAME)) 5675 ISAM #100,1,NAME 5700 IF ERF(100) = 33 & THEN PRINT "RECORD NOT FOUND" : UNLOKR #100 : GOTO PROMPT 5725 IF ERF(100) # 0 THEN GOTO ISAM'ERROR 5750 READ #100,LABEL : OLD'NAME=NAME : PTR=RELKEY1 : ORG'BUF=LABEL 5775 PRINT "NAME: ";NAME : NEW'NAME = "" 5800 PRINT "ADDRESS: ";ADDRESS 5825 PRINT "STATE: ";STATE 5850 PRINT "HASH: ";HASH 5875 PRINT : INPUT "NEW NAME: ";NEW'NAME 5900 NEW'NAME=NEW'NAME + SPACE(25-LEN(NEW'NAME)) 5925 ! First, add the new record with new primary key 5950 ISAM #100,1,NEW'NAME 5975 IF ERF(100)=0 THEN UNLOKR #100 : PRINT "NEW NAME ALREADY EXITS" : & GOTO CHG'PRIMARY 6000 IF ERF(100) # 33 THEN GOTO ISAM'ERROR 6025 NAME=NEW'NAME 6050 ISAM #100,5,NAME 6075 IF ERF(100) # 0 THEN GOTO ISAM'ERROR 6100 WRITEL #100,LABEL 6125 PTR1=RELKEY1 6150 DEL'SEC: 6175 ISAM #200,4,HASH 6200 IF ERF(200)=33 THEN GOTO ADD'SEC 6225 IF ERF(200) # 0 THEN GOTO ISAM'ERROR 6250 ADD'SEC: 6275 RELKEY1=PTR1 6300 ISAM #200,3,HASH 6325 IF ERF(200) # 0 THEN GOTO ISAM'ERROR 6350 ISAM #100,3,NAME 6375 IF ERF(100) # 0 THEN GOTO ISAM'ERROR 6400 ! Second, delete the old copy of the record; Secondary is already gone 6425 ISAM #100,1,OLD'NAME 6450 IF ERF(100)=33 THEN UNLOKR #100 : GOTO PROMPT 6475 IF ERF(100) # 0 THEN GOTO ISAM'ERROR 6500 READL #100, NEW'BUF 6525 IF NEW'BUF # ORG'BUF THEN GOTO CANNOT'BACK'OFF 6550 ISAM #100,4,OLD'NAME 6575 IF ERF(100) # 0 THEN GOTO ISAM'ERROR 6600 ISAM #100,6,OLD'NAME 6625 IF ERF(100) # 0 THEN GOTO ISAM'ERROR 6650 GOTO PROMPT 6675 CANNOT'BACK'OFF: 6700 UNLOKR #100 : PRINT "Cannot complete change." 6725 PRINT "Old record changed in interim. Old HASH not on"; 6750 PRINT " file." : GOTO PROMPT