100 ! ISAM Sample Program

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