|
DataMuseum.dkPresents historical artifacts from the history of: CP/M |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about CP/M Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 30464 (0x7700)
Types: TextFile
Names: »DATABASE.SRC«
└─⟦57f0389e8⟧ Bits:30005761 SW1611 Access Manager v. 1.0
└─⟦this⟧ »DATABASE.SRC«
PROGRAM DATABASE;
(* ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
DATABASE EXAMPLE VERSION 1.0 9/14/82 0935
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*)
(*$E-*)
CONST
MAX_KEY = 2;
MAX_FIELD = 7;
MAX_KEY_LEN = 20;
MAX_FLD_LEN = 20;
NAME_LEN = 14;
FLD_NAME_LEN = 18;
ACTION_LEN = 4;
NEW_MODE = 1;
OLD_MODE = 2;
YES = 1;
NO = 0;
SAVE = 1;
DELT = 2;
BACK = 3;
CONT = 4;
STOP = 5;
TYPE
BYTEPTR = ^BYTE;
KEYSTR = STRINGÆMAX_KEY_LENÅ;
FLDSTR = STRINGÆMAX_FLD_LENÅ;
FLD_REC = RECORD;
LENBYTE : BYTE;
FLDCHR : ARRAYÆ1..MAX_FLD_LENÅ OF CHAR;
END;
CUST_REC = RECORD;
CDF : CHAR;
FLD : ARRAYÆ1..99Å OF CHAR;
END;
(*
WORKING VARIABLES
*)
VAR
KEY,TERMINAL,TRAP_ERRORS,TIME_OUT_TEST_DELAY,NO_BUFFERS : INTEGER;
NO_NODE_SECTORS,NO_DATA_FILES,NO_KEYZ,FILE_NO : INTEGER;
RECORD_LENGTH : INTEGER;
SET_LENGTH,IDX_KEY,SPACE : KEYSTR;
OLD_ACTION : INTEGER;
FILNAME : STRINGÆNAME_LENÅ;
NULL_BYT : BYTE;
NULL_CHR : CHAR;
(*
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
DATABASE FIELD & KEY DESCRIPTORS
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*)
DATBUF : CUST_REC;
DATBUF_PTR : ^CUST_REC;
FLD_NAME,KEY_NAME : ARRAYÆ0..MAX_FIELDÅ OF STRINGÆFLD_NAME_LENÅ;
FLD_LEN : ARRAYÆ0..MAX_FIELDÅ OF BYTE;
OLD_FLD,NEW_FLD : ARRAYÆ0..MAX_FIELDÅ OF FLDSTR;
NO_FIELDS : INTEGER;
IDX_NAME : ARRAYÆ0..MAX_KEYÅ OF STRINGÆNAME_LENÅ;
KEY_LEN,KEY_MAP,KEY_TYPE,KEY_NUM,KEY_DUP : ARRAYÆ0..MAX_KEYÅ OF
INTEGER;
FOR_EVER : BOOLEAN;
UNIQ_KEY,NLOCK,SLOCK,XLOCK,SFILE,XFILE,RLOCK : INTEGER;
(*
INTERFACE TO ACCESS MANAGER(tm)
AM86EXTR.PSC CONTAINS THE EXTERNAL DEFINITIONS OF THE ACCESS MANAGER
ROUTINES
*)
æ$I AM86EXTR.PSCå
EXTERNAL FUNCTION @BDOS86(FUNC:INTEGER; PARM:BYTEPTR) : INTEGER;
PROCEDURE GO_OP_SYS;
VAR
DUMMY : INTEGER;
DPARM : BYTEPTR;
BEGIN
DUMMY := @BDOS86(0,DPARM);
END;æGO_OP_SYSå
PROCEDURE DATA_BASE;
BEGIN
CLRSCR;
CASE MAIN_MENU OF
1: DBNEW;
2: DBSCAN;
3: DBLIST;
4: DBSTAT;
5: DBSAVE;
6: DBTERM;
END;æOF CASEå
END;æDATA_BASEå
(*
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
ENTER NEW CUSTOMERS
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*)
PROCEDURE DBNEW;
VAR
KEY,LOCK_CODE,NDRN,DRN,CHOICE : INTEGER;
SAVE_KEY,LDRN,NO_LISTED : INTEGER;
ROUTE : CHAR;
CONTINUE,STAYPUT : BOOLEAN;
L_VALUE,U_VALUE,CONV_TARGET,TARGET : KEYSTR;
ACTION : INTEGER;
BEGIN
ACTION := SAVE;
WHILE (ACTION = SAVE) DO
BEGIN
ACTION := NEWDAT;
LOCK_CODE := 0;
IF ACTION = SAVE THEN
BEGIN
NDRN := UPDATE(0);
LOCK_CODE := FRELOK(FILE_NO,XLOCK,NDRN);
END;
IF LOCK_CODE <> 0 THEN
LOCK_TYPE(8);
END;
END;æDBNEWå
(*
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
SCAN/UPDATE/DELETE CUSTOMERS
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*)
PROCEDURE DBSCAN;
VAR
KEY,LOCK_CODE,NDRN,DRN,CHOICE : INTEGER;
SAVE_KEY,LDRN,NO_LISTED : INTEGER;
ROUTE : CHAR;
CONTINUE,STAYPUT : BOOLEAN;
L_VALUE,U_VALUE,CONV_TARGET,TARGET : KEYSTR;
ACTION : INTEGER;
BEGIN
KEY := SEARCH_KEY;
WRITELN;
WRITELN ('Enter target value for ',KEY_NAMEÆKEYÅ,',');
WRITE(' or enter a period (.) to see main menu>>');
READLN(TARGET);
IF TARGET <> '.' THEN
BEGIN
CONV_TARGET := TARGET;
KEY_FORMAT(KEY,CONV_TARGET);
STAYPUT := TRUE;
WHILE (STAYPUT) DO
BEGIN
DRN := SERKEY(KEY_NUMÆKEYÅ,FILE_NO,SLOCK,
CONV_TARGET,IDX_KEY);
IF ERRCOD <> 0 THEN
ERROR_TYPE(KEY,2);
IF LOKCOD <> 0 THEN
STAYPUT := CHECK_LOCK(KEY,DRN)
ELSE
STAYPUT :=FALSE;
END;
OLD_ACTION := CONT;
CONTINUE := TRUE;
WHILE (CONTINUE) AND (DRN <> 0) DO
BEGIN
LDRN := DRN;
READ_CUST(DRN);
ACTION := OLDDAT(DRN);
SAVE_KEY := KEY;
IF ACTION = SAVE THEN
DRN := UPDATE(DRN);
IF ACTION = DELT THEN
DELETE(DRN);
IF (ACTION <> DELT) AND (FRELOK(FILE_NO,RLOCK,LDRN) <> 0)
THEN LOCK_TYPE(2);
IF (ACTION = SAVE) OR (ACTION = DELT) THEN
BEGIN
KEY := SAVE_KEY;
ACTION := OLD_ACTION;
END;
OLD_ACTION := ACTION;
CONV_TARGET := COPY(IDX_KEY,1,KEY_LENÆKEYÅ);
IDX_KEY := SET_LENGTH;
LOCK_CODE := 0;
STAYPUT := TRUE;
WHILE (STAYPUT) DO
BEGIN
IF ACTION = CONT THEN
BEGIN
DRN := AFTKEY(KEY_NUMÆKEYÅ,FILE_NO,
SLOCK, CONV_TARGET,IDX_KEY);
LOCK_CODE := LOKCOD;
END;
IF ACTION = BACK THEN
BEGIN
DRN := BEFKEY(KEY_NUMÆKEYÅ,FILE_NO,
SLOCK, CONV_TARGET,IDX_KEY);
LOCK_CODE := LOKCOD;
END;
IF LOCK_CODE <> 0 THEN
STAYPUT := CHECK_LOCK(KEY,DRN)
ELSE
STAYPUT := FALSE;
END;
IF ACTION = STOP THEN
CONTINUE := FALSE;
END;
WRITELN;
WRITELN('SCAN ENDED');
PAUSE;
END;
END;æDBSCANå
(*
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
LIST CUSTOMERS
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*)
PROCEDURE DBLIST;
VAR
KEY,LOCK_CODE,NDRN,DRN,CHOICE : INTEGER;
SAVE_KEY,LDRN,NO_LISTED : INTEGER;
ROUTE : CHAR;
CONTINUE,STAYPUT : BOOLEAN;
L_VALUE,U_VALUE,CONV_TARGET,TARGET : KEYSTR;
ACTION : INTEGER;
BEGIN
KEY := SEARCH_KEY;
WRITELN;
WRITE('Do you want listing routed to printer (Y/N) >>');
READLN(ROUTE);
IF ROUTE = 'y' THEN ROUTE := 'Y';
WRITELN;
WRITELN;
WRITELN(
'Enter lower and upper limits for ',KEY_NAMEÆKEYÅ,' listing;');
WRITE(' place values on separate lines >>') ;
READLN(L_VALUE);
READLN(U_VALUE);
KEY_FORMAT(KEY,L_VALUE);
KEY_FORMAT(KEY,U_VALUE);
DRN := SERKEY(KEY_NUMÆKEYÅ,FILE_NO,SLOCK,
L_VALUE,IDX_KEY);
IF LOKCOD <> 0 THEN
SKIP_LOCK(KEY,DRN);
NO_LISTED := 0;
WHILE (DRN <> 0) AND (COMPARE(KEY,IDX_KEY,U_VALUE) <= 0) DO
BEGIN
READ_CUST(DRN);
PRINT_CUST(ROUTE);
NO_LISTED := NO_LISTED + 1;
IF FRELOK(FILE_NO,SLOCK,DRN) <> 0 THEN
LOCK_TYPE(4);
L_VALUE := COPY(IDX_KEY,1,KEY_LENÆKEYÅ);
IDX_KEY := SET_LENGTH;
DRN := AFTKEY(KEY_NUMÆKEYÅ,FILE_NO,SLOCK,
L_VALUE,IDX_KEY);
IF LOKCOD <> 0 THEN
SKIP_LOCK(KEY,DRN);
END;
IF DRN <> 0 THEN
LOCK_CODE := FRELOK(FILE_NO,SLOCK,DRN)
ELSE
LOCK_CODE := 0;
IF LOCK_CODE <> 0 THEN
LOCK_TYPE(5);
WRITELN;
WRITELN(NO_LISTED,' records listed.');
PAUSE;
END;æDBLISTå
(*
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
DATABASE STATISTICS
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*)
PROCEDURE DBSTAT;
VAR
KEY,LOCK_CODE,NDRN,DRN,CHOICE : INTEGER;
SAVE_KEY,LDRN,NO_LISTED : INTEGER;
ROUTE : CHAR;
CONTINUE,STAYPUT : BOOLEAN;
L_VALUE,U_VALUE,CONV_TARGET,TARGET : KEYSTR;
ACTION : INTEGER;
BEGIN
CLRSCR;
WRITELN(FILNAME,' has ',GETDFS(FILE_NO),
' records; currently, ',GETDFU(FILE_NO),
' of them are in use.');
WRITELN;
WRITELN;
WRITELN(' INDEX','ENTRIES':30);
WRITELN ('-----------------','-------':22);
FOR KEY := 0 TO MAX_KEY DO
WRITELN(KEY_NAMEÆKEYÅ:16,' ':16,NOKEYS(KEY):7);
WRITELN;
WRITELN;
PAUSE;
END;æDBSTATå
(*
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
SAVE DATABASE UPDATES & RESTART
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*)
PROCEDURE DBSAVE;
VAR
KEY,LOCK_CODE,NDRN,DRN,CHOICE : INTEGER;
SAVE_KEY,LDRN,NO_LISTED : INTEGER;
ROUTE : CHAR;
CONTINUE,STAYPUT : BOOLEAN;
L_VALUE,U_VALUE,CONV_TARGET,TARGET : KEYSTR;
ACTION : INTEGER;
BEGIN
IF SAVDAT(FILE_NO) <> 0 THEN
ERROR_TYPE(0,7);
FOR KEY := 0 TO MAX_KEY DO
IF SAVIDX(KEY_NUMÆKEYÅ) <> 0 THEN
ERROR_TYPE(KEY,3);
END;æDBSAVEå
(*
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
SAVE DATABASE UPDATES & TERMINATE
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*)
PROCEDURE DBTERM;
VAR
KEY,LOCK_CODE,NDRN,DRN,CHOICE : INTEGER;
SAVE_KEY,LDRN,NO_LISTED : INTEGER;
ROUTE : CHAR;
CONTINUE,STAYPUT : BOOLEAN;
L_VALUE,U_VALUE,CONV_TARGET,TARGET : KEYSTR;
ACTION : INTEGER;
BEGIN
IF FRELOK(FILE_NO,SFILE,0) <> 0 THEN
ERROR_TYPE(0,13);
IF CLSDAT(FILE_NO) <> 0 THEN
ERROR_TYPE(0,15);
FOR KEY := 0 TO MAX_KEY DO
IF CLSIDX(KEY_NUMÆKEYÅ) <> 0 THEN
ERROR_TYPE(KEY,16);
WRITELN;
WRITELN(' *** SUCCESSFUL TERMINATION ***');
FOR_EVER := FALSE;
END;æDBTERMå
(*
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
BEGINNING OF UTILITY FUNCTIONS
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
CLEAR SCREEN ROUTINE
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*)
PROCEDURE CLRSCR;
VAR
DUMMY : INTEGER;
BEGIN
FOR DUMMY := 1 TO 24 DO
WRITELN;
END;æCLRSCRå
(*
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
MAIN MENU ROUTINE
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*)
FUNCTION MAIN_MENU : INTEGER;
VAR
OP : INTEGER;
BEGIN
WRITELN(' ':19,' ACCESS MANAGER(tm) DEMONSTRATION');
WRITELN;
WRITELN(' ':19,' Customer Database Operations') ;
WRITELN(' ':19,' Terminal ',TERMINAL);
WRITELN(' ':19,' ****************************');
WRITELN;
WRITELN;
WRITELN(' 1. Enter New Customers');
WRITELN(' 2. Scan/Update/Delete Customer Records');
WRITELN(' 3. List Customer Records');
WRITELN(' 4. Database Statistics');
WRITELN(' 5. Save All Files & Restart Operations');
WRITELN(' 6. Terminate Operations');
OP := 0;
WHILE (OP < 1) OR (OP > 6) DO
BEGIN
WRITELN;
WRITE('Enter desired operation number>>');
READLN(OP);
END;
MAIN_MENU := OP;
END;æMAIN_MENUå
(*
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
SELECT SEARCH KEY ROUTINE
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*)
FUNCTION SEARCH_KEY : INTEGER;
VAR
KEY,KEY_NO : INTEGER;
BEGIN
CLRSCR;
WRITELN(' ':24,'Customer Database Search Keys');
WRITELN;
WRITELN;
WRITELN;
FOR KEY := 0 TO MAX_KEY DO
BEGIN
KEY_NO := KEY + 1;
WRITELN(KEY_NO,' - ',KEY_NAMEÆKEYÅ)
END;
KEY := 0;
WHILE (KEY < 1) OR (KEY > NO_KEYZ) DO
BEGIN
WRITELN;
WRITELN;
WRITE('Enter desired key number>>');
READLN(KEY);
END;
SEARCH_KEY := KEY-1;
END;æSEARCH_KEYå
(*
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
ERROR HANDLING
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*)
PROCEDURE ERROR_TYPE(INFO,LOCALE : INTEGER);
VAR
DUMMY : INTEGER;
PROCEDURE ET_CLOSE;
VAR
T_KEY : INTEGER;
BEGIN
DUMMY := CLSDAT(FILE_NO);
FOR T_KEY := 0 TO MAX_KEY DO
IF T_KEY <> INFO THEN DUMMY := CLSIDX(KEY_NUMÆT_KEYÅ);
ET_STOP;
END;
PROCEDURE ET_PCLOSE;
VAR
L_KEY,T_KEY : INTEGER;
BEGIN
L_KEY := INFO + 1;
IF L_KEY > MAX_KEY THEN GO_OP_SYS;
FOR T_KEY := L_KEY TO MAX_KEY DO
DUMMY := CLSIDX(KEY_NUMÆT_KEYÅ);
END;
PROCEDURE ET_STOP;
BEGIN
WRITELN;
WRITELN('DATABASE TERMINATING WITH ERROR CODE #',ERRCOD);
GO_OP_SYS;
END;
BEGIN
WRITELN;
WRITELN;
WRITE('User Error #',ERRCOD,' occurred while trying to ');
CASE LOCALE OF
1: WRITELN('open ',IDX_NAMEÆINFOÅ);
2: WRITELN('search ',KEY_NAMEÆINFOÅ,' Index File');
3: WRITELN('save ',IDX_NAMEÆINFOÅ);
4: WRITELN('remove old key from ',IDX_NAMEÆINFOÅ);
5: WRITELN('enter key into ',IDX_NAMEÆINFOÅ);
6: WRITELN('delete key from ',IDX_NAMEÆINFOÅ);
7: BEGIN
WRITELN('save ',FILNAME);
INFO := -1;
END;
8: WRITELN('get a new data record',' (',FILE_NO,')');
9: WRITELN('delete data record #',INFO);
10: WRITELN('open ',FILNAME,' (',FILE_NO,')');
11: WRITELN('read data record #',INFO);
12: WRITELN('write data record #',INFO);
13: WRITELN('release shared file lock on ',FILNAME);
14: BEGIN
WRITELN('initialize user.');
GO_OP_SYS;
END;
15: BEGIN
WRITELN('close ',FILNAME);
INFO := -1;
END;
16: WRITELN('close ',IDX_NAMEÆINFOÅ);
END;æOF CASEå
IF (LOCALE = 1) OR ((LOCALE > 7) AND (LOCALE < 13)) THEN
ET_STOP
ELSE IF (LOCALE = 2) OR ((LOCALE > 3) AND (LOCALE < 7)) OR
(LOCALE = 13) THEN
ET_CLOSE
ELSE
ET_PCLOSE;
END;æERROR_TYPEå
PROCEDURE LOCK_TYPE(LOCALE : INTEGER);
VAR
T_KEY,DUMMY : INTEGER;
BEGIN
WRITELN('Lock Type: ',LOCALE,' Lock Code:',LOKCOD);
DUMMY := CLSDAT(FILE_NO);
FOR T_KEY := 0 TO MAX_KEY DO
DUMMY := CLSIDX(KEY_NUMÆT_KEYÅ);
GO_OP_SYS;
END;æLOCK_TYPEå
(*
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
READ DATA RECORD ROUTINE
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*)
PROCEDURE READ_CUST(DRN : INTEGER);
VAR
FLD,CHR,POS_PTR : INTEGER;
TMP_FLD : FLDSTR;
FLDPTR : ^FLD_REC;
BEGIN
IF READAT(FILE_NO,DRN,DATBUF_PTR) <> 0 THEN
ERROR_TYPE(DRN,11);
FLDPTR := ADDR(TMP_FLD); (* PTR TO STRING *)
POS_PTR := 0;
FOR FLD := 0 TO MAX_FIELD DO
BEGIN
FLDPTR^.LENBYTE := FLD_LENÆFLDÅ;
FOR CHR := 1 TO FLDPTR^.LENBYTE DO
FLDPTR^.FLDCHRÆCHRÅ := DATBUF.FLDÆPOS_PTR + CHRÅ;
WHILE (FLDPTR^.FLDCHRÆFLDPTR^.LENBYTEÅ = ' ') AND
(FLDPTR^.LENBYTE > 0) DO
FLDPTR^.LENBYTE := FLDPTR^.LENBYTE - 1;
OLD_FLDÆFLDÅ := TMP_FLD;
POS_PTR := POS_PTR + FLD_LENÆFLDÅ;
END;
END;æREAD_CUSTå
(*
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
LIST CUSTOMER RECORD ROUTINE
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*)
PROCEDURE PRINT_CUST(ROUTE : CHAR);
VAR
DUMMY : INTEGER;
LIST_FILE : TEXT;
BEGIN
IF ROUTE = 'Y' THEN
ASSIGN(LIST_FILE,'LST:')
ELSE
ASSIGN(LIST_FILE,'CON:');
RESET(LIST_FILE);
WRITELN(LIST_FILE);
WRITELN(LIST_FILE,' ':4,OLD_FLDÆ0Å:10,' ',OLD_FLDÆ7Å);
WRITELN(LIST_FILE,' ':24,OLD_FLDÆ1Å,' ',OLD_FLDÆ2Å);
WRITELN(LIST_FILE,' ':24,OLD_FLDÆ3Å);
WRITELN(LIST_FILE,' ':24,OLD_FLDÆ4Å,', ',OLD_FLDÆ5Å,' ',OLD_FLDÆ6Å);
WRITELN(LIST_FILE);
CLOSE(LIST_FILE,DUMMY);
END;æPRINT_CUSTå
(*
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
PAUSE ROUTINE
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*)
PROCEDURE PAUSE;
VAR
NULL : CHAR;
BEGIN
WRITE('Press "RETURN" to continue ---');
READLN(NULL);
END;æPAUSEå
(*
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
CONVERT TARGET VALUE TO KEY FORMAT ROUTINE
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*)
PROCEDURE KEY_FORMAT(KEY : INTEGER;VAR TARGET : KEYSTR);
VAR
TEMP : STRINGÆ40Å;
BEGIN
IF UNIQ_KEY = KEY THEN
EXIT
ELSE
BEGIN
TEMP := CONCAT(TARGET,SPACE);
TEMP :=COPY(TEMP,1,KEY_LENÆKEYÅ-2);
TARGET := CONCAT(TEMP,NULL_CHR,NULL_CHR);
END;
END;æKEY_FORMATå
(*
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
COMPARE IDX_KEY & U_VALUE ROUTINE
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*)
FUNCTION COMPARE(KEY : INTEGER; IDXVAL,UPVAL : KEYSTR) : INTEGER;
VAR
KL : INTEGER;
C1,C2 : STRINGÆ40Å;
BEGIN
IF KEY = UNIQ_KEY THEN
KL := KEY_LENÆKEYÅ
ELSE
KL := KEY_LENÆKEYÅ-2;
C1 := CONCAT(IDXVAL,SPACE);
C1 := COPY(C1,1,KL);
C2 := CONCAT(UPVAL,SPACE);
C2 := COPY(C2,1,KL);
IF C1<C2 THEN
COMPARE := -1
ELSE IF C1>C2 THEN
COMPARE := 1
ELSE
COMPARE := 0;
END;æCOMPAREå
(*
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
CHECK LOCK ROUTINES
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*)
PROCEDURE SKIP_LOCK(KEY,DRN : INTEGER);
VAR
L_VALUE : KEYSTR;
BEGIN
WHILE (DRN <> 0) AND (LOKCOD <> 0) DO
BEGIN
L_VALUE := COPY(IDX_KEY,1,KEY_LENÆKEYÅ);
IDX_KEY := SET_LENGTH;
DRN := AFTKEY(KEY_NUMÆKEYÅ,FILE_NO,SLOCK,
L_VALUE,IDX_KEY);
END;
END;æSKIP_LOCKå
FUNCTION CHECK_LOCK(KEY,DRN : INTEGER) : BOOLEAN;
VAR
CONV_TARGET : KEYSTR;
DUMMY : CHAR;
BEGIN
WRITELN;
WRITE(
'Enter a "W" if you wish to wait for locked record(s)>>');
READLN(DUMMY);
IF (DUMMY = 'W') OR (DUMMY = 'w') THEN
BEGIN
CHECK_LOCK := TRUE;
EXIT;
END;
WHILE (DRN <> 0) AND (LOKCOD <> 0) DO
BEGIN
CONV_TARGET := COPY(IDX_KEY,1,KEY_LENÆKEYÅ);
IDX_KEY := SET_LENGTH;
IF OLD_ACTION = CONT THEN
DRN := AFTKEY(KEY_NUMÆKEYÅ,FILE_NO,
SLOCK, CONV_TARGET,IDX_KEY)
ELSE
DRN := BEFKEY(KEY_NUMÆKEYÅ,FILE_NO,
SLOCK, CONV_TARGET,IDX_KEY);
END;
CHECK_LOCK := FALSE;
END;æCHECK_LOCKå
(*
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
WARNING MESSAGES
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*)
PROCEDURE WARNING_TYPE(KEY,LOCALE,RET_CODE : INTEGER);
BEGIN
WRITELN;
WRITE('WARNING...Return Code #',RET_CODE,
' occurred while trying to ');
CASE LOCALE OF
1: WRITELN('remove old key from ',IDX_NAMEÆKEYÅ);
2: WRITELN('enter key into ',IDX_NAMEÆKEYÅ);
3: WRITELN('delete key from ',IDX_NAMEÆKEYÅ);
END; æOF CASEå
PAUSE;
END;æWARNING_TYPEå
(*
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
ADD NEW KEY VALUE ROUTINE
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*)
PROCEDURE ADD_A_KEY(KEY,DRN : INTEGER);
VAR
RET_CODE,K_FLD : INTEGER;
BEGIN
K_FLD := KEY_MAPÆKEYÅ;
(*
REMOVE OLD KEY VALUE
*)
RET_CODE := DELKEY(KEY_NUMÆKEYÅ,FILE_NO,
XLOCK,OLD_FLDÆK_FLDÅ,DRN);
IF ERRCOD <> 0 THEN
ERROR_TYPE(KEY,4);
IF LOKCOD <> 0 THEN
LOCK_TYPE(6);
IF RET_CODE <> 1 THEN
WARNING_TYPE(KEY,1,RET_CODE);
(*
ADD NEW KEY VALUE
*)
RET_CODE := ADDKEY(KEY_NUMÆKEYÅ,FILE_NO,
XLOCK,NEW_FLDÆK_FLDÅ,DRN);
IF ERRCOD <> 0 THEN
ERROR_TYPE(KEY,5);
IF LOKCOD <> 0 THEN
LOCK_TYPE(7);
IF RET_CODE <> 1 THEN
WARNING_TYPE(KEY,2,RET_CODE);
END;æADD_A_KEYå
(*
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
WRITE NEW DATA RECORD ROUTINE
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*)
PROCEDURE WRITE_CUST(DRN : INTEGER);
VAR
FLD,CHR,POS_PTR : INTEGER;
TMP_FLD : FLDSTR;
FLDPTR : ^FLD_REC;
BEGIN
DATBUF.CDF := NULL_CHR;
FLDPTR := ADDR(TMP_FLD); (* PTR TO STRING *)
POS_PTR := 0;
FOR FLD := 0 TO MAX_FIELD DO
BEGIN
TMP_FLD := NEW_FLDÆFLDÅ;
FOR CHR := 1 TO FLDPTR^.LENBYTE DO
DATBUF.FLDÆPOS_PTR + CHRÅ :=
FLDPTR^.FLDCHRÆCHRÅ;
WHILE (FLDPTR^.LENBYTE < FLD_LENÆFLDÅ) DO
BEGIN
FLDPTR^.LENBYTE := FLDPTR^.LENBYTE + 1;
DATBUF.FLDÆPOS_PTR + FLDPTR^.LENBYTEÅ := ' ';
END;
POS_PTR := POS_PTR + FLD_LENÆFLDÅ;
END;
IF WRTDAT(FILE_NO,DRN,DATBUF_PTR) <> 0 THEN
ERROR_TYPE(DRN,12);
END;æWRITE_CUSTå
(*
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
DELETE KEY VALUE FROM INDEX ROUTINE
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*)
PROCEDURE DEL_A_KEY(KEY,DRN : INTEGER);
VAR
RET_CODE,K_FLD : INTEGER;
BEGIN
K_FLD := KEY_MAPÆKEYÅ;
RET_CODE := DELKEY(KEY_NUMÆKEYÅ,FILE_NO,
XLOCK,OLD_FLDÆK_FLDÅ,DRN);
IF ERRCOD <> 0 THEN
ERROR_TYPE(KEY,6);
IF LOKCOD <> 0 THEN
LOCK_TYPE(10);
IF RET_CODE <> 1 THEN
WARNING_TYPE(KEY,3,RET_CODE);
END;æDEL_A_KEYå
(*
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
UPDATE INDICES & DATA FILE ROUTINE
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*)
FUNCTION UPDATE(DATA_RECORD : INTEGER) : INTEGER;
VAR
FLD,KEY : INTEGER;
BEGIN
IF DATA_RECORD = 0 THEN
BEGIN
DATA_RECORD := NEWREC(FILE_NO,XLOCK);
IF ERRCOD <> 0 THEN
ERROR_TYPE(0,8);
IF LOKCOD <> 0 THEN
LOCK_TYPE(3) ;
END;
UPDATE := DATA_RECORD;
FOR KEY := 0 TO MAX_KEY DO
BEGIN
FLD := KEY_MAPÆKEYÅ;
IF OLD_FLDÆFLDÅ <> NEW_FLDÆFLDÅ THEN
ADD_A_KEY(KEY,DATA_RECORD);
END;
FOR FLD := 0 TO MAX_FIELD DO
IF OLD_FLDÆFLDÅ <> NEW_FLDÆFLDÅ THEN
BEGIN
WRITE_CUST(DATA_RECORD);
EXIT;
END;
END;æUPDATEå
(*
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
DELETE INDEX & DATA FILE ENTRY ROUTINE
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*)
PROCEDURE DELETE(DATA_RECORD : INTEGER);
VAR
FLD,KEY : INTEGER;
BEGIN
FOR KEY := 0 TO MAX_KEY DO
BEGIN
FLD := KEY_MAPÆKEYÅ;
IF OLD_FLDÆFLDÅ <> '' THEN
DEL_A_KEY(KEY,DATA_RECORD);
END;
IF RETREC(FILE_NO,XLOCK,DATA_RECORD) <> 0 THEN
ERROR_TYPE(DATA_RECORD,9);
IF LOKCOD <> 0 THEN
LOCK_TYPE(9);
END;æDELETEå
(*
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
NEW DATA ENTRY ROUTINE
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*)
FUNCTION NEWDAT : INTEGER;
VAR
TMPFLD : STRINGÆ40Å;
UNIQUE : BOOLEAN;
TMPDAT : INTEGER;
FLD,OP_VAL,FLD_NO : INTEGER;
OP1 : CHAR;
OP1_BYT : BYTE;
LABEL
111;
BEGIN
FOR FLD := 0 TO MAX_FIELD DO
OLD_FLDÆFLDÅ := '';
CLRSCR;
WRITELN(' ':19,'Enter New Customer Information');
WRITELN(' ':19,'******************************');
WRITELN;
WRITELN;
WRITELN(
' ÆPress "RETURN" for customer # to see main menu.Å');
WRITELN;
FOR FLD := 0 TO MAX_FIELD DO
BEGIN
FLD_NO := FLD + 1;
111:
WRITE(FLD_NO:6,' - ',FLD_NAMEÆFLDÅ:20,
'(',FLD_LENÆFLDÅ:2,') >>');
READLN(NEW_FLDÆFLDÅ);
IF (FLD = KEY_MAPÆUNIQ_KEYÅ) AND (NEW_FLDÆFLDÅ = '')
THEN BEGIN
NEWDAT := STOP;
EXIT;
END;
IF FLD = KEY_MAPÆUNIQ_KEYÅ THEN
BEGIN
NEW_FLDÆFLDÅ := CONCAT('0000',NEW_FLDÆFLDÅ);
RIGHT(NEW_FLDÆFLDÅ,FLD_LENÆFLDÅ);
UNIQUE := TEST_UNIQUENESS;
END
ELSE
BEGIN
TMPFLD := CONCAT(NEW_FLDÆFLDÅ,
' ');
NEW_FLDÆFLDÅ := COPY(TMPFLD,1,FLD_LENÆFLDÅ);
UNIQUE := TRUE;
END;
IF üUNIQUE THEN GOTO 111;
END;
WHILE (FOR_EVER) DO
BEGIN
WRITELN;
WRITELN;
WRITELN;
WRITELN(' ':19,'Current customer information');
WRITELN;
FOR FLD := 0 TO MAX_FIELD DO
BEGIN
FLD_NO := FLD + 1;
WRITELN(FLD_NO:6,' - ',FLD_NAMEÆFLDÅ:20,' ',
NEW_FLDÆFLDÅ);
END;
OP_VAL := 0;
WHILE (OP_VAL < 1) OR (OP_VAL > NO_FIELDS) DO
BEGIN
WRITELN;
WRITELN;
WRITELN(
'Enter S to save data, Field # to change data,');
WRITE(
'D to delete data, or E to end input >>') ;
READLN(OP1);
TMPDAT := 0;
IF (OP1 = 'S') OR (OP1 = 's') THEN
TMPDAT := SAVE;
IF (OP1 = 'D') OR (OP1 = 'd') THEN
TMPDAT := DELT;
IF (OP1 = 'E') OR (OP1 = 'e') THEN
TMPDAT := STOP;
IF TMPDAT <> 0 THEN
BEGIN
NEWDAT := TMPDAT;
EXIT;
END;
OP1_BYT := OP1;
OP_VAL := OP1_BYT - 48;
END;
UPDATE_FIELD(OP_VAL);
END;
END;æNEWDATå
FUNCTION OLDDAT(DRN: INTEGER) : INTEGER;
VAR
UNIQUE : BOOLEAN;
TMPDAT : INTEGER;
FLD,OP_VAL,FLD_NO : INTEGER;
OP1 : CHAR;
OP1_BYT : BYTE;
BEGIN
FOR FLD := 0 TO MAX_FIELD DO
NEW_FLDÆFLDÅ := OLD_FLDÆFLDÅ;
CLRSCR;
WHILE (FOR_EVER) DO
BEGIN
WRITELN;
WRITELN;
WRITELN;
WRITELN(' ':19,'Current customer information');
WRITELN;
FOR FLD := 0 TO MAX_FIELD DO
BEGIN
FLD_NO := FLD + 1;
WRITELN(FLD_NO:6,' - ',FLD_NAMEÆFLDÅ:20,' ',
NEW_FLDÆFLDÅ);
END;
OP_VAL := 0;
WHILE (OP_VAL < 1) OR (OP_VAL > NO_FIELDS) DO
BEGIN
WRITELN;
WRITELN;
WRITELN(
'Enter C to continue scan, Field # to change data, S to save changes,');
WRITE(
'D to delete data, B for back scan, or E to end scan >>');
READLN(OP1);
TMPDAT := 0;
IF (OP1 = 'C') OR (OP1 = 'c') THEN
TMPDAT := CONT;
IF (OP1 = 'S') OR (OP1 = 's') THEN
TMPDAT := SAVE;
IF (OP1 = 'D') OR (OP1 = 'd') THEN
TMPDAT := SET_XLOCK(OP1,DRN);
IF (OP1 = 'B') OR (OP1 = 'b') THEN
TMPDAT := BACK;
IF (OP1 = 'E') OR (OP1 = 'e') THEN
TMPDAT := STOP;
IF TMPDAT <> 0 THEN
BEGIN
OLDDAT := TMPDAT;
EXIT;
END;
OP1_BYT := OP1;
OP_VAL := OP1_BYT - 48;
END;
UPDATE_FIELD(OP_VAL);
END;
END;æOLDDATå
FUNCTION SET_XLOCK(OP : CHAR; DRN : INTEGER) : INTEGER;
VAR
DUMMY : CHAR;
BEGIN
DUMMY := 'W';
WHILE (DUMMY = 'W') AND (SETLOK(FILE_NO,XLOCK,DRN) <> 0) DO
BEGIN
WRITELN;
WRITELN('Customer update on hold due to record lock');
WRITE(
'Enter W if you wish to wait or any other key to cancel update>>');
READLN(DUMMY);
IF DUMMY = 'w' THEN DUMMY := 'W';
END;
IF DUMMY = 'W' THEN
BEGIN
IF OP = 'S' THEN
SET_XLOCK := SAVE
ELSE
SET_XLOCK := DELT;
END
ELSE
SET_XLOCK := OLD_ACTION;
END;æSET_XLOCKå
(*
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
UPDATE DATA FIELD ROUTINE
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*)
PROCEDURE UPDATE_FIELD(FLD_NO : INTEGER);
VAR
TMPFLD : STRINGÆ40Å;
TEST : BOOLEAN;
FIELD_NO : INTEGER;
BEGIN
FIELD_NO := FLD_NO-1;
TEST := FALSE;
WHILE (üTEST) DO
BEGIN
WRITELN;
WRITE('Input new ',FLD_NAMEÆFIELD_NOÅ,'>>');
READLN(NEW_FLDÆFIELD_NOÅ);
IF FIELD_NO = KEY_MAPÆUNIQ_KEYÅ THEN
BEGIN
NEW_FLDÆFIELD_NOÅ := CONCAT('0000',NEW_FLDÆFIELD_NOÅ);
RIGHT(NEW_FLDÆFIELD_NOÅ,FLD_LENÆFIELD_NOÅ);
END
ELSE
BEGIN
TMPFLD := CONCAT(NEW_FLDÆFIELD_NOÅ,
' ');
NEW_FLDÆFIELD_NOÅ := COPY(TMPFLD,1,FLD_LENÆFIELD_NOÅ);
END;
IF (FIELD_NO = KEY_MAPÆUNIQ_KEYÅ) AND (NEW_FLDÆFIELD_NOÅ <>
OLD_FLDÆFIELD_NOÅ) THEN
TEST := TEST_UNIQUENESS
ELSE
TEST := TRUE;
END;
END;æUPDATE_FIELDå
(*
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
CUST # UNIQUENESS TEST ROUTINE
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*)
FUNCTION TEST_UNIQUENESS : BOOLEAN;
VAR
TEMP : INTEGER;
TEST : FLDSTR;
BEGIN
TEST := NEW_FLDÆKEY_MAPÆUNIQ_KEYÅÅ;
TEMP := GETKEY(UNIQ_KEY,0,NLOCK,TEST);
IF LOKCOD <> 0 THEN
LOCK_TYPE(12);
IF TEMP = 0 THEN
TEST_UNIQUENESS := TRUE
ELSE
BEGIN
WRITELN;
WRITELN(' *** Already Assigned ***');
WRITELN;
TEST_UNIQUENESS := FALSE;
END;
END;æTEST_UNIQUENESSå
(*
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
RIGHT STRING ROUTINE
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*)
PROCEDURE RIGHT(VAR FLDVAL : FLDSTR; FLDLEN : INTEGER);
BEGIN
FLDVAL := COPY(FLDVAL,LENGTH(FLDVAL)-FLDLEN+1,FLDLEN);
END;æRIGHTå
(*
END OF UTILITY FUNCTIONS
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
*)
(*
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
SET-UP DATABASE FIELD & KEY DESCRIPTORS
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*)
BEGIN
NO_FIELDS := MAX_FIELD + 1;
FLD_NAMEÆ0Å := 'Customer Number';
FLD_LENÆ0Å := 4;
FLD_NAMEÆ1Å := 'First Name';
FLD_LENÆ1Å := 16;
FLD_NAMEÆ2Å := 'Last Name';
FLD_LENÆ2Å := 20;
FLD_NAMEÆ3Å := 'Street Address';
FLD_LENÆ3Å := 20;
FLD_NAMEÆ4Å := 'City';
FLD_LENÆ4Å := 20;
FLD_NAMEÆ5Å := 'State';
FLD_LENÆ5Å := 2;
FLD_NAMEÆ6Å := 'Zipcode';
FLD_LENÆ6Å := 9;
FLD_NAMEÆ7Å := 'Customer Status';
FLD_LENÆ7Å := 8;
KEY_LENÆ0Å:=10;
KEY_TYPEÆ0Å:=0;
KEY_MAPÆ0Å:=2 ; (* KEY 0 = LAST NAME *)
KEY_LENÆ1Å:=11;
KEY_TYPEÆ1Å:=0;
KEY_MAPÆ1Å:=6 ; (* KEY 1 = ZIPCODE *)
KEY_LENÆ2Å:=4 ;
KEY_TYPEÆ2Å:=0;
KEY_MAPÆ2Å:=0 ; (* KEY 2 = CUST NUMBER *)
UNIQ_KEY := 2 ; (* USED IN TEST OF UNIQUENESS *)
FOR KEY := 0 TO MAX_KEY DO
BEGIN
IF KEY = UNIQ_KEY THEN
KEY_DUPÆKEYÅ := NO
ELSE
KEY_DUPÆKEYÅ := YES;
KEY_NAMEÆKEYÅ := FLD_NAMEÆKEY_MAPÆKEYÅÅ;
END;
IDX_NAMEÆ0Å := 'NAME.IDX';
IDX_NAMEÆ1Å := 'ZIPC.IDX';
IDX_NAMEÆ2Å := 'NUMB.IDX';
NLOCK := 0; (* IGNORE LOCKS *)
SLOCK := 1; (* SHARED RECORD LOCK *)
XLOCK := 2; (* EXCLUSIVE RECORD LOCK *)
SFILE := 3; (* SHARED FILE LOCK *)
XFILE := 4; (* EXCLUSIVE FILE LOCK *)
RLOCK := 5; (* RELEASE SLOCK) OR (XLOCK *)
(*
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
INITIALIZE INDEX FILES
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*)
SET_LENGTH := '12345678901';
IDX_KEY := SET_LENGTH;
SPACE := ' ';
(*
SET TERMINAL TO -1 FOR AUTOMATIC ASSIGNMENT BY ACCESS MANAGER
*)
TERMINAL := -1;
TRAP_ERRORS := YES;
TIME_OUT_TEST_DELAY := 2; (* APPROXIMATELY 2 SECONDS *)
TERMINAL := INTUSR(TERMINAL,TRAP_ERRORS,TIME_OUT_TEST_DELAY);
IF ERRCOD <> 0 THEN
ERROR_TYPE(0,14);
NO_BUFFERS := 5;
NO_NODE_SECTORS := 4;
NO_DATA_FILES := 1;
NO_KEYZ := MAX_KEY + 1;
IF SETUP(NO_BUFFERS,NO_KEYZ,NO_NODE_SECTORS,NO_DATA_FILES) <> 0 THEN
BEGIN
WRITELN('Illegal SETUP Parameters');
EXIT;
END;
FOR KEY := 0 TO MAX_KEY DO
BEGIN
KEY_NUMÆKEYÅ := OPNIDX(-1,IDX_NAMEÆKEYÅ,
KEY_LENÆKEYÅ, KEY_TYPEÆKEYÅ,KEY_DUPÆKEYÅ);
IF ERRCOD <> 0 THEN
ERROR_TYPE(KEY,1);
END;
(*
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
INITIALIZE DATA FILE
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*)
FILE_NO := -1;
RECORD_LENGTH := 100;
FILNAME := 'CUSTOMER.DAT';
FILE_NO := OPNDAT(FILE_NO,SFILE,FILNAME,RECORD_LENGTH);
IF ERRCOD <> 0 THEN
ERROR_TYPE(0,10);
IF LOKCOD <> 0 THEN
LOCK_TYPE(1);
(*
CUST_REC IS THE DATA FILE BUFFER AREA
*)
DATBUF_PTR := ADDR(DATBUF);
(*
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
BEGIN DATABASE OPERATION
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*)
NULL_BYT := 0;
NULL_CHR := NULL_BYT;
FOR_EVER := TRUE;
WHILE (FOR_EVER) DO
DATA_BASE;
EXIT;
END.
«eof»