|
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: 21888 (0x5580)
Types: TextFile
Names: »DATABAS1.PLI«
└─⟦57f0389e8⟧ Bits:30005761 SW1611 Access Manager v. 1.0
└─⟦this⟧ »DATABAS1.PLI«
DATABASE:
PROC OPTIONS (MAIN);
/* ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
DATABASE EXAMPLE VERSION 1.0 01/06/83 0916
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*/
%INCLUDE 'DATABASE.DCL';
/*
INTERFACE TO AM86(tm)
AM86EXTR.PLI CONTAINS THE EXTERNAL DEFINITIONS OF THE AM-86 ROUTINES
*/
%INCLUDE 'AM86EXTR.PLI';
DCL
DUMMY_KEY FIXED,
ENTDAT ENTRY (CHAR(3),FIXED) RETURNS (CHAR(ACTION_LEN));
/*
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
SET-UP DATABASE FIELD & KEY DESCRIPTORS
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*/
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;
DCL
DATBUF_PTR POINTER,
1 CUST_REC,
2 CDF CHAR(1),
2 CNO CHAR(4),
2 CFN CHAR(16),
2 CLN CHAR(20),
2 CST CHAR(20),
2 CTY CHAR(20),
2 CSA CHAR(2),
2 CZP CHAR(9),
2 CSU CHAR(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 */
DO KEY = 0 TO MAX_KEY;
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 AM-86
*/
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
CALL ERROR_TYPE(0,14);
NO_BUFFERS = 5;
NO_NODE_SECTORS = 4;
NO_DATA_FILES = 1;
NO_KEYS = MAX_KEY + 1;
IF SETUP(NO_BUFFERS,NO_KEYS,NO_NODE_SECTORS,NO_DATA_FILES) ü= 0 THEN
DO;
PUT SKIP LIST('Illegal SETUP Parameters');
STOP;
END;
DUMMY_KEY = -1;
DO KEY = 0 TO MAX_KEY;
KEY_NUM(KEY) = OPNIDX(DUMMY_KEY,IDX_NAME(KEY),
KEY_LEN(KEY), KEY_TYPE(KEY),KEY_DUP(KEY));
IF ERRCOD() ü= 0 THEN
CALL 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
CALL ERROR_TYPE(0,10);
IF LOKCOD() ü= 0 THEN
CALL LOKTYP(1);
/*
CUST_REC IS THE DATA FILE BUFFER AREA
*/
DATBUF_PTR = ADDR(CUST_REC);
/*
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
BEGIN DATABASE OPERATION
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*/
OPEN FILE (SYSCON) OUTPUT TITLE('$CON');
OPEN FILE (SYSLST) OUTPUT TITLE('$LST');
FOR_EVER = YESBIT;
DO WHILE (FOR_EVER);
CALL DATA_BASE();
END;
DATA_BASE:
PROC;
DCL
(LOCK_CODE,NDRN,DRN,CHOICE) FIXED,
(SAVE_KEY,LDRN,NO_LISTED) FIXED,
ROUTE CHAR(1),
(CONTINUE,STAYPUT) BIT(1),
(L_VALUE,U_VALUE,CONV_TARGET,TARGET) CHAR(MAX_KEY_LEN) VAR,
ACTION CHAR(ACTION_LEN);
CALL CLRSCR();
CHOICE = MAIN_MENU();
GOTO DB(CHOICE);
/*
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
ENTER NEW CUSTOMERS
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*/
DB(1):
ACTION = ENTDAT('NEW',0);
LOCK_CODE = 0;
IF ACTION = 'SAVE' THEN
DO;
NDRN = UPDATE(0);
LOCK_CODE = FRELOK(FILE_NO,XLOCK,NDRN);
END;
IF LOCK_CODE ü= 0 THEN
CALL LOKTYP(8);
IF ACTION = 'SAVE' THEN
GOTO DB(1);
ELSE
RETURN;
/*
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
SCAN/UPDATE/DELETE CUSTOMERS
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*/
DB(2):
KEY = SEARCH_KEY();
PUT SKIP(2) EDIT ('Enter target value for ',KEY_NAME(KEY),',',
' or enter a period (.) to see main menu>>')
(3A,SKIP,A);
GET LIST (TARGET);
IF TARGET = '.' THEN RETURN;
CONV_TARGET = KEY_FORMAT(KEY,TARGET);
STAYPUT = YESBIT;
DO WHILE (STAYPUT);
DRN = SERKEY(KEY_NUM(KEY),FILE_NO,SLOCK,
CONV_TARGET,IDX_KEY);
IF ERRCOD() ü= 0 THEN
CALL ERROR_TYPE(KEY,2);
IF LOKCOD() ü= 0 THEN
STAYPUT = CHECK_LOCK(KEY,DRN);
ELSE
STAYPUT =NOBIT;
END;
OLD_ACTION = 'CONT';
CONTINUE = YESBIT;
DO WHILE (CONTINUE & DRN ü= 0);
LDRN = DRN;
CALL READ_CUST(DRN);
ACTION = ENTDAT('OLD',DRN);
SAVE_KEY = KEY;
IF ACTION = 'SAVE' THEN
DRN = UPDATE(DRN);
IF ACTION = 'DELT' THEN
CALL DELETE(DRN);
IF ACTION ü= 'DELT' & FRELOK(FILE_NO,RLOCK,LDRN) ü= 0
THEN CALL LOKTYP(2);
IF ACTION = 'SAVE' ø ACTION = 'DELT' THEN
DO;
KEY = SAVE_KEY;
ACTION = OLD_ACTION;
END;
OLD_ACTION = ACTION;
CONV_TARGET = SUBSTR(IDX_KEY,1,KEY_LEN(KEY));
IDX_KEY = SET_LENGTH;
LOCK_CODE = 0;
STAYPUT = YESBIT;
DO WHILE (STAYPUT);
IF ACTION = 'CONT' THEN
DO;
DRN = AFTKEY(KEY_NUM(KEY),FILE_NO,
SLOCK, CONV_TARGET,IDX_KEY);
LOCK_CODE = LOKCOD();
END;
IF ACTION = 'BACK' THEN
DO;
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 = NOBIT;
END;
IF ACTION = 'STOP' THEN
CONTINUE = NOBIT;
END;
PUT SKIP(2) LIST ('SCAN ENDED');
CALL PAUSE();
RETURN;
/*
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
LIST CUSTOMERS
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*/
DB(3):
KEY = SEARCH_KEY();
PUT SKIP(2) LIST (
'Do you want listing routed to printer (Y/N) >>');
GET LIST (ROUTE);
IF ROUTE = 'y' THEN ROUTE = 'Y';
PUT SKIP(3) EDIT (
'Enter lower and upper limits for ',KEY_NAME(KEY),' listing',
' separate values with a space >>') (3A,SKIP,A);
GET LIST (L_VALUE,U_VALUE);
L_VALUE = KEY_FORMAT(KEY,L_VALUE);
U_VALUE = KEY_FORMAT(KEY,U_VALUE);
DRN = SERKEY(KEY_NUM(KEY),FILE_NO,SLOCK,
L_VALUE,IDX_KEY);
IF LOKCOD() ü= 0 THEN
CALL SKIP_LOCK(KEY,DRN);
NO_LISTED = 0;
DO WHILE (DRN ü= 0 & COMPARE(KEY,IDX_KEY,U_VALUE) <= 0);
CALL READ_CUST(DRN);
CALL PRINT_CUST(ROUTE);
NO_LISTED = NO_LISTED + 1;
IF FRELOK(FILE_NO,SLOCK,DRN) ü= 0 THEN
CALL LOKTYP(4);
L_VALUE = SUBSTR(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
CALL 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
CALL LOKTYP(5);
PUT SKIP(2) EDIT (NO_LISTED,' records listed.') (F(6),A);
CALL PAUSE();
RETURN;
/*
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
DATABASE STATISTICS
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*/
DB(4):
CALL CLRSCR();
PUT SKIP EDIT (FILNAME,' has ',GETDFS(FILE_NO),
' records; currently, ',GETDFU(FILE_NO),
' of them are in use.') (2A,F(6),A,F(6),A);
PUT SKIP(4) EDIT (' INDEX','ENTRIES') (A,COLUMN(30),A);
PUT SKIP EDIT ('-----------------','-------') (A,COLUMN(30),A);
DO KEY = 0 TO MAX_KEY;
PUT SKIP EDIT (KEY_NAME(KEY),NOKEYS(KEY)) (A,COLUMN(30),F(6));
END;
PUT SKIP(4);
CALL PAUSE();
RETURN;
/*
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
SAVE DATABASE UPDATES & RESTART
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*/
DB(5):
IF SAVDAT(FILE_NO) ü= 0 THEN
CALL ERROR_TYPE(0,7);
DO KEY = 0 TO MAX_KEY;
IF SAVIDX(KEY_NUM(KEY)) ü= 0 THEN
CALL ERROR_TYPE(KEY,3);
END;
RETURN;
/*
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
SAVE DATABASE UPDATES & TERMINATE
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*/
DB(6):
CLOSE FILE (SYSLST);
IF CLSDAT(FILE_NO) ü= 0 THEN
CALL ERROR_TYPE(0,15);
DO KEY = 0 TO MAX_KEY;
IF CLSIDX(KEY_NUM(KEY)) ü= 0 THEN
CALL ERROR_TYPE(KEY,16);
END;
IF FRELOK(FILE_NO,SFILE,0) ü= 0 THEN
CALL ERROR_TYPE(0,13);
PUT SKIP(2) LIST (' *** SUCCESSFUL TERMINATION ***');
STOP;
END DATA_BASE;
/*
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
BEGINNING OF UTILITY FUNCTIONS
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
CLEAR SCREEN ROUTINE
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*/
CLRSCR:
PROC EXTERNAL;
DCL
DUMMY FIXED BINARY(7);
DO DUMMY = 1 TO 24;
PUT SKIP;
END;
END CLRSCR;
/*
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
MAIN MENU ROUTINE
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*/
MAIN_MENU:
PROC RETURNS (FIXED);
DCL
OP FIXED;
PUT SKIP EDIT (' AM-86(tm) DEMONSTRATION') (X(20),A);
PUT SKIP(2) EDIT(' Customer Database Operations') (X(20),A);
PUT SKIP EDIT(' Terminal ',TERMINAL) (X(20),A,F(2));
PUT SKIP EDIT(' ****************************') (X(20),A);
PUT SKIP(3) EDIT('1. Enter New Customers') (X(5),A);
PUT SKIP EDIT('2. Scan/Update/Delete Customer Records') (X(5),A);
PUT SKIP EDIT('3. List Customer Records') (X(5),A);
PUT SKIP EDIT('4. Database Statistics') (X(5),A);
PUT SKIP EDIT('5. Save All Files & Restart Operations') (X(5),A);
PUT SKIP EDIT('6. Terminate Operations') (X(5),A);
OP = 0;
DO WHILE (OP < 1 ø OP > 6);
PUT SKIP(2) LIST ('Enter desired operation number>>');
GET LIST (OP);
END;
RETURN(OP);
END MAIN_MENU;
/*
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
SELECT SEARCH KEY ROUTINE
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*/
SEARCH_KEY:
PROC RETURNS (FIXED);
DCL
(KEY,KEY_NO) FIXED;
CALL CLRSCR();
PUT EDIT ('Customer Database Search Keys') (X(25),A);
PUT SKIP (3);
DO KEY = 0 TO MAX_KEY;
KEY_NO = KEY + 1;
PUT SKIP EDIT(KEY_NO,' - ',KEY_NAME(KEY)) (X(5),F(3),2A);
END;
KEY = 0;
DO WHILE (KEY < 1 ø KEY > NO_KEYS);
PUT SKIP(3) LIST('Enter desired key number>>');
GET LIST (KEY);
END;
RETURN(KEY-1);
END SEARCH_KEY;
/*
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
ERROR HANDLING
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*/
ERROR_TYPE:
PROC (INFO,TYPE);
DCL
(T_KEY,INFO,DUMMY,TYPE) FIXED;
PUT SKIP(3) EDIT ('User Error #',ERRCOD(),' occurred while trying to ')
(A,F(4),A);
GOTO ET(TYPE);
ET(1): PUT EDIT ('open ',IDX_NAME(INFO)) (2A);
GOTO ET_STOP;
ET(2): PUT EDIT ('search ',KEY_NAME(INFO),' Index File') (3A);
GOTO ET_CLOSE;
ET(3): PUT EDIT('save ',IDX_NAME(INFO)) (2A);
GOTO ET_PCLOSE;
ET(4): PUT EDIT('remove old key from ',IDX_NAME(INFO)) (2A);
GOTO ET_CLOSE;
ET(5): PUT EDIT('enter key into ',IDX_NAME(INFO)) (2A);
GOTO ET_CLOSE;
ET(6): PUT EDIT('delete key from ',IDX_NAME(INFO)) (2A);
GOTO ET_CLOSE;
ET(7): PUT EDIT('save ',FILNAME) (2A);
INFO = -1;
GOTO ET_PCLOSE;
ET(8): PUT EDIT('get a new data record',' (',FILE_NO,')') (2A,F(3),A);
GOTO ET_STOP;
ET(9): PUT EDIT('delete data record #',INFO) (A,F(6));
GOTO ET_STOP;
ET(10): PUT EDIT('open ',FILNAME,' (',FILE_NO,')') (2A,F(3),A);
GOTO ET_STOP;
ET(11): PUT EDIT('read data record #',INFO) (A,F(6));
GOTO ET_STOP;
ET(12): PUT EDIT('write data record #',INFO) (A,F(6));
GOTO ET_STOP;
ET(13): PUT EDIT('release shared file lock on ',FILNAME) (2A);
GOTO ET_STOP;
ET(14): PUT EDIT('initialize user.') (A);
STOP;
ET(15): PUT EDIT('close ',FILNAME) (2A);
INFO = -1;
GOTO ET_PCLOSE;
ET(16): PUT EDIT('close ',IDX_NAME(INFO)) (2A);
GOTO ET_PCLOSE;
ET_CLOSE:
DUMMY = CLSDAT(FILE_NO);
DO T_KEY = 0 TO MAX_KEY;
IF T_KEY ü= INFO THEN DUMMY = CLSIDX(KEY_NUM(T_KEY));
END;
GOTO ET_STOP;
ET_PCLOSE:
T_KEY = INFO + 1;
IF T_KEY>MAX_KEY THEN STOP;
DO INFO = T_KEY TO MAX_KEY;
DUMMY = CLSIDX(KEY_NUM(INFO));
END;
ET_STOP:
PUT SKIP(2) EDIT('DEMONSTRATION TERMINATING WITH ERROR CODE #',
ERRCOD()) (A,F(4));
STOP;
END ERROR_TYPE;
LOKTYP:
PROC (TYPE) EXTERNAL;
DCL
(T_KEY,DUMMY,TYPE) FIXED;
PUT SKIP EDIT('Lock Type: ',TYPE,' Lock Code:',LOKCOD())
(A,F(3),A,F(3));
DUMMY = CLSDAT(FILE_NO);
DO T_KEY = 0 TO MAX_KEY;
DUMMY = CLSIDX(KEY_NUM(T_KEY));
END;
STOP;
END LOKTYP;
/*
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
STRIP TRAILING BLANKS
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*/
STRIP_BLANKS:
PROC (OLD_VAL) RETURNS(CHAR(MAX_FLD_LEN) VAR);
DCL
OLD_VAL CHAR(MAX_FLD_LEN),
(TEST,FLDLEN) FIXED;
FLDLEN = LENGTH(OLD_VAL);
DO TEST = FLDLEN TO 1 BY -1;
IF SUBSTR(OLD_VAL,TEST,1) ü= ' ' THEN
RETURN (SUBSTR(OLD_VAL,1,TEST));
END;
RETURN('');
END STRIP_BLANKS;
/*
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
READ DATA RECORD ROUTINE
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*/
READ_CUST:
PROC (DRN);
DCL
DRN FIXED;
IF READAT(FILE_NO,DRN,DATBUF_PTR) ü= 0 THEN
CALL ERROR_TYPE(DRN,11);
OLD_FLD(0) = STRIP_BLANKS(CNO);
OLD_FLD(1) = STRIP_BLANKS(CFN);
OLD_FLD(2) = STRIP_BLANKS(CLN);
OLD_FLD(3) = STRIP_BLANKS(CST);
OLD_FLD(4) = STRIP_BLANKS(CTY);
OLD_FLD(5) = STRIP_BLANKS(CSA);
OLD_FLD(6) = STRIP_BLANKS(CZP);
OLD_FLD(7) = STRIP_BLANKS(CSU);
END READ_CUST;
/*
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
LIST CUSTOMER RECORD ROUTINE
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*/
PRINT_CUST:
PROC (ROUTE);
DCL
ROUTE CHAR(1),
LIST_FILE FILE VARIABLE;
LFRMT:
FORMAT(X(28),5A);
IF ROUTE = 'Y' THEN
LIST_FILE = SYSLST;
ELSE
LIST_FILE = SYSCON;
PUT FILE(LIST_FILE) SKIP (2) EDIT(OLD_FLD(0),OLD_FLD(7))
(X(4),A,COLUMN(15),A);
PUT FILE(LIST_FILE) EDIT(OLD_FLD(1),' ',OLD_FLD(2)) (col(29),5A);
PUT FILE(LIST_FILE) SKIP EDIT(OLD_FLD(3)) (R(LFRMT));
PUT FILE(LIST_FILE) SKIP EDIT(OLD_FLD(4),', ',OLD_FLD(5),' ',OLD_FLD(6))
(R(LFRMT));
PUT FILE(LIST_FILE) SKIP;
END PRINT_CUST;
/*
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
PAUSE ROUTINE
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*/
PAUSE:
PROC;
DCL
DUMMY CHAR(1);
PUT SKIP(2) LIST ('Enter any character to continue ---');
GET LIST (DUMMY);
END PAUSE;
/*
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
CONVERT TARGET VALUE TO KEY FORMAT ROUTINE
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*/
KEY_FORMAT:
PROC (KEY,TARGET) RETURNS (CHAR(MAX_KEY_LEN) VAR);
DCL
KEY FIXED,
TEMP CHAR(40) VAR,
TARGET CHAR(MAX_KEY_LEN) VAR;
IF UNIQ_KEY = KEY THEN
RETURN(TARGET);
ELSE
DO;
TEMP = TARGET øø SPACE;
RETURN(SUBSTR(TEMP,1,KEY_LEN(KEY)-2) øø
ASCII(0) øø ASCII(0));
END;
END KEY_FORMAT;
/*
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
COMPARE IDX_KEY & U_VALUE ROUTINE
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*/
COMPARE:
PROC (KEY,IDXVAL,UPVAL) RETURNS (FIXED);
DCL
(KL,KEY) FIXED,
(C1,C2) CHAR(40) VAR,
(IDXVAL,UPVAL) CHAR(MAX_KEY_LEN) VAR;
IF KEY = UNIQ_KEY THEN
KL = KEY_LEN(KEY);
ELSE
KL = KEY_LEN(KEY)-2;
C1 = IDXVAL øø SPACE;
C1 = SUBSTR(C1,1,KL);
C2 = UPVAL øø SPACE;
C2 = SUBSTR(C2,1,KL);
IF C1<C2 THEN
RETURN(-1);
ELSE IF C1>C2 THEN
RETURN(1);
ELSE
RETURN(0);
END COMPARE;
/*
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
CHECK LOCK ROUTINES
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*/
SKIP_LOCK:
PROC (KEY,DRN);
DCL
L_VALUE CHAR(MAX_KEY_LEN) VAR,
(KEY,DRN) FIXED;
DO WHILE (DRN ü= 0 & LOKCOD() ü= 0);
L_VALUE = SUBSTR(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;
CHECK_LOCK:
PROC (KEY,DRN) RETURNS (BIT(1));
DCL
CONV_TARGET CHAR(MAX_KEY_LEN) VAR,
(KEY,DRN) FIXED,
DUMMY CHAR(1);
PUT SKIP(2) LIST(
'Enter a "W" if you wish to wait for locked record(s)>>');
GET LIST (DUMMY);
IF DUMMY = 'W' ø DUMMY = 'w' THEN
RETURN(YESBIT);
DO WHILE (DRN ü= 0 & LOKCOD() ü= 0);
CONV_TARGET = SUBSTR(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;
RETURN(NOBIT);
END CHECK_LOCK;
/*
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
WARNING MESSAGES
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*/
WARNING_TYPE:
PROC (KEY,TYPE,RET_CODE);
DCL
(KEY,TYPE,RET_CODE) FIXED;
PUT SKIP(2) EDIT ('WARNING...Return Code #',RET_CODE,
' occurred while trying to ') (A,F(3),A);
GOTO WT(TYPE);
WT(1): PUT EDIT ('remove old key from ',IDX_NAME(KEY)) (2A);
CALL PAUSE();
RETURN;
WT(2): PUT EDIT ('enter key into ',IDX_NAME(KEY)) (2A);
CALL PAUSE();
RETURN;
WT(3): PUT EDIT ('delete key from ',IDX_NAME(KEY)) (2A);
CALL PAUSE();
RETURN;
END WARNING_TYPE;
/*
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
ADD NEW KEY VALUE ROUTINE
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*/
ADD_KEY:
PROC (KEY,DRN);
DCL
(KEY,RET_CODE,K_FLD,DRN) FIXED;
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
CALL ERROR_TYPE(KEY,4);
IF LOKCOD() ü= 0 THEN
CALL LOKTYP(6);
IF RET_CODE ü= 1 THEN
CALL 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
CALL ERROR_TYPE(KEY,5);
IF LOKCOD() ü= 0 THEN
CALL LOKTYP(7);
IF RET_CODE ü= 1 THEN
CALL WARNING_TYPE(KEY,2,RET_CODE);
END ADD_KEY;
/*
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
WRITE NEW DATA RECORD ROUTINE
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*/
WRITE_CUST:
PROC (DRN);
DCL
DRN FIXED;
CDF = ASCII(0); /* CLEAR DELETE FLAG */
CNO = NEW_FLD(0);
CFN = NEW_FLD(1);
CLN = NEW_FLD(2);
CST = NEW_FLD(3);
CTY = NEW_FLD(4);
CSA = NEW_FLD(5);
CZP = NEW_FLD(6);
CSU = NEW_FLD(7);
IF WRTDAT(FILE_NO,DRN,DATBUF_PTR) ü= 0 THEN
CALL ERROR_TYPE(DRN,12);
END WRITE_CUST;
/*
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
DELETE KEY VALUE FROM INDEX ROUTINE
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*/
DEL_KEY:
PROC (KEY,DRN);
DCL
(KEY,RET_CODE,K_FLD,DRN);
K_FLD = KEY_MAP(KEY);
RET_CODE = DELKEY(KEY_NUM(KEY),FILE_NO,
XLOCK,OLD_FLD(K_FLD),DRN);
IF ERRCOD() ü= 0 THEN
CALL ERROR_TYPE(KEY,6);
IF LOKCOD() ü= 0 THEN
CALL LOKTYP(10);
IF RET_CODE ü= 1 THEN
CALL WARNING_TYPE(KEY,3,RET_CODE);
END DEL_KEY;
/*
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
UPDATE INDICES & DATA FILE ROUTINE
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*/
UPDATE:
PROC (DATA_RECORD) RETURNS (FIXED);
DCL
(FLD,KEY) FIXED,
(TMP_REC,DATA_RECORD) FIXED;
IF DATA_RECORD = 0 THEN
DO;
TMP_REC = NEWREC(FILE_NO,XLOCK);
IF ERRCOD() ü= 0 THEN
CALL ERROR_TYPE(0,8);
IF LOKCOD() ü= 0 THEN
CALL LOKTYP(3) ;
END;
ELSE
TMP_REC = DATA_RECORD;
DO KEY = 0 TO MAX_KEY;
FLD = KEY_MAP(KEY);
IF OLD_FLD(FLD) ü= NEW_FLD(FLD) THEN
CALL ADD_KEY(KEY,TMP_REC);
END;
DO FLD = 0 TO MAX_FIELD;
IF OLD_FLD(FLD) ü= NEW_FLD(FLD) THEN
DO;
CALL WRITE_CUST(TMP_REC);
RETURN(TMP_REC);
END;
END;
RETURN(TMP_REC);
END UPDATE;
/*
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
DELETE INDEX & DATA FILE ENTRY ROUTINE
:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*/
DELETE:
PROC (DATA_RECORD);
DCL
(DATA_RECORD,FLD,KEY) FIXED;
DO KEY = 0 TO MAX_KEY;
FLD = KEY_MAP(KEY);
IF OLD_FLD(FLD) ü= '' THEN
CALL DEL_KEY(KEY,DATA_RECORD);
END;
IF RETREC(FILE_NO,XLOCK,DATA_RECORD) ü= 0 THEN
CALL ERROR_TYPE(DATA_RECORD,9);
IF LOKCOD() ü= 0 THEN
CALL LOKTYP(9);
END DELETE;
/*
END OF UTILITY FUNCTIONS
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
*/
END;
«eof»