Adabas ダイレクトコールを使用する VAX-11 PASCAL の例です。付録 B で定義された Adabas ファイルが使用されています。
PROGRAM EXAMPLE (OUTPUT);
(**************************************************************** * * * A D A B A S / V M S PASCAL example program * * -------------------------------------------- * * * * Compile, link and run this program by typing : * * * * $ PASCAL EXAMPLE * * $ LINK EXAMPLE * * $ RUN EXAMPLE * * * * Function : * * * * Find in the default database all people * * named 'SMITH' and increase their salary * * by 10% * * * ****************************************************************)
CONST
EXAMPLE_DB = 0; (* Use default database *)
EMPLOYEES_FILE = 11; (* and example file 'EMPLOYEES' *)
L_FB = 8; (* Lengths of the buffers *)
L_RB_OP = 7; (* used when calling ADABAS *)
L_SB = 5; (* Note that these buffers have *) L_VB = 5; (* to be defined in the VAR *)
L_IB = 4; (* area due to the call by *)
L_RB = 4; (* reference mechanism used *)
TYPE
INT1 = 0..255;
INT2 = 0..65535;
CHAR2 = PACKED ARRAY [1..2] OF CHAR;
CHAR4 = PACKED ARRAY [1..4] OF CHAR;
CHAR8 = PACKED ARRAY [1..8] OF CHAR;
CONTROL_BLOCK = PACKED RECORD
FILLER1,
COMMAND_CODE : CHAR2;
COMMAND_ID : CHAR4;
FILE_NUMBER,
DB_ID : INT1;
RESPONSE_CODE : INT2;
ISN,
ISN_LL,
ISN_QUANTITY : INTEGER;
FMT_BUF_LNG,
REC_BUF_LNG,
SEA_BUF_LNG,
VAL_BUF_LNG,
ISN_BUF_LNG : INT2;
CMD_OPT_1,
CMD_OPT_2 : CHAR;
ADDITIONS_1 : CHAR8;
ADDITIONS_2 : CHAR4;
ADDITIONS_3,
ADDITIONS_4,
ADDITIONS_5 : CHAR8;
COMMAND_TIME : INTEGER;
USER_AREA : CHAR4;
END;
FMT_BUF = PACKED ARRAY [1..L_FB] OF CHAR;
REC_BUF = PACKED RECORD
CASE INTEGER OF
0 : (OP : PACKED ARRAY [1..L_RB_OP] OF CHAR);
1 : (SALARY : INTEGER);
END;
SEA_BUF = PACKED ARRAY [1..L_SB] OF CHAR;
VAL_BUF = PACKED ARRAY [1..L_VB] OF CHAR;
VAR
CB : CONTROL_BLOCK;
FB : FMT_BUF;
RB : REC_BUF;
SB : SEA_BUF;
VB : VAL_BUF;
IB : INTEGER;
UPD_COUNT : INTEGER; (* No. of records updated *)
OLD_SALARY : INTEGER;
PROCEDURE ADABAS (VAR CB : CONTROL_BLOCK;
VAR FB : FMT_BUF;
VAR RB : REC_BUF;
VAR SB : SEA_BUF;
VAR VB : VAL_BUF;
VAR IB : INTEGER); EXTERN;
FUNCTION OPEN_DATABASE:BOOLEAN;
BEGIN
CB.DB_ID := EXAMPLE_DB;
CB.COMMAND_CODE := 'OP';
CB.REC_BUF_LNG := L_RB_OP;
RB.OP := 'UPD=11.';
REPEAT
ADABAS (CB, FB, RB, SB, VB, IB);
UNTIL CB.RESPONSE_CODE <> 9;
OPEN_DATABASE := CB.RESPONSE_CODE = 0
END;
FUNCTION CLOSE_DATABASE:BOOLEAN;
BEGIN
CB.COMMAND_CODE:= 'CL';
ADABAS (CB, FB, RB, SB, VB, IB);
CLOSE_DATABASE := CB.RESPONSE_CODE = 0
END;
FUNCTION ISSUE_BT:BOOLEAN;
BEGIN
CB.COMMAND_CODE:= 'BT';
ADABAS (CB, FB, RB, SB, VB, IB);
ISSUE_BT := CB.RESPONSE_CODE = 0
END;
FUNCTION FIND_RECORD:BOOLEAN;
BEGIN
CB.COMMAND_CODE := 'L4';
IF CB.ISN_QUANTITY = 0 THEN
BEGIN
CB.COMMAND_CODE := 'S4';
CB.FILE_NUMBER := EMPLOYEES_FILE;
CB.COMMAND_ID := 'FIND';
CB.FMT_BUF_LNG := L_FB;
CB.REC_BUF_LNG := L_RB;
CB.SEA_BUF_LNG := L_SB;
CB.VAL_BUF_LNG := L_VB;
CB.ISN_BUF_LNG := L_IB;
CB.CMD_OPT_2 := 'N';
FB := 'ASN,4,F.'; (* Salary as 4 byte integer *)
SB := 'AE,5.'; (* Searching via name *)
VB := 'SMITH'; (* Searching for 'SMITH' *)
END;
ADABAS (CB, FB, RB, SB, VB, IB);
FIND_RECORD := CB.RESPONSE_CODE = 0
END;
FUNCTION UPDATE_RECORD:BOOLEAN;
BEGIN
RB.SALARY := RB.SALARY + RB.SALARY DIV 10;
CB.COMMAND_CODE := 'A1';
ADABAS (CB, FB, RB, SB, VB, IB);
UPDATE_RECORD := CB.RESPONSE_CODE = 0
END;
PROCEDURE RESPONSE;
BEGIN
WRITELN('** Response code ', CB.RESPONSE_CODE:0,
' from ADABAS for command ', CB.COMMAND_CODE);
END;
(* Main program *)
BEGIN
WRITELN ('PASCAL example program for calling ADABAS (OpenVMS)');
IF NOT OPEN_DATABASE THEN
RESPONSE
ELSE
BEGIN
UPD_COUNT := 0;
CB.ISN_QUANTITY := 0;
IF FIND_RECORD THEN
BEGIN
WRITELN ('Found : ',CB.ISN_QUANTITY:5,' records');
WHILE CB.ISN_QUANTITY <> 0 DO
BEGIN
OLD_SALARY := RB.SALARY;
IF NOT UPDATE_RECORD THEN
CB.ISN_QUANTITY := 0
ELSE
BEGIN
WRITELN (' ISN ',CB.ISN:8,' old salary = ',
OLD_SALARY:10,' new salary = ',RB.SALARY:10);
UPD_COUNT := UPD_COUNT + 1;
IF NOT FIND_RECORD THEN
BEGIN
CB.ISN_QUANTITY := 0;
IF CB.RESPONSE_CODE = 3 THEN
CB.RESPONSE_CODE := 0;
END;
END;
END;
END;
IF CB.RESPONSE_CODE <> 0 THEN
BEGIN
RESPONSE;
CB.RESPONSE_CODE := 0;
IF UPD_COUNT <> 0 THEN
IF ISSUE_BT THEN
UPD_COUNT := 0
ELSE
RESPONSE;
END;
IF CB.RESPONSE_CODE = 0 THEN
BEGIN
WRITELN ('Changed : ',UPD_COUNT:5,' records');
IF NOT CLOSE_DATABASE THEN
RESPONSE;
END;
END;
END.