Adabas ダイレクトコールを使用する VAX-11 PL/I の例です。付録 B で定義された Adabas ファイルが使用されています。
EXAMPLE: PROC OPTIONS (MAIN) ;
/******************************************************** * * * A D A B A S / V M S PL/1 example program * * --------------------------------------------- * * * * Compile, link and run this program by typing: * * * * $ PLI EXAMPLE * * $ LINK EXAMPLE * * $ RUN EXAMPLE * * * * Function: * * Find in the default database all people * * named 'SMITH' and increase their salary * * by 10% * * * ********************************************************/
%REPLACE EXAMPLE_DB BY 0 ;
%REPLACE PERSON_FILE BY 11;
/*************************
* ADABAS Control block *
*************************/
DCL ADABAS ENTRY (ANY,ANY,ANY,ANY,ANY,ANY)
OPTIONS (VARIABLE) ;
DCL 1 CB,
2 FILLER1 CHAR(2),
2 COMMAND_CODE CHAR(2),
2 COMMAND_ID CHAR(4),
2 FILE_NUMBER CHAR(1),
2 DB_ID CHAR(1),
2 RESPONSE_CODE FIXED BINARY(15),
2 ISN FIXED BINARY(31),
2 ISN_LL FIXED BINARY(31),
2 ISN_QUANTITY FIXED BINARY(31),
2 FMT_BUF_LNG FIXED BINARY(15),
2 REC_BUF_LNG FIXED BINARY(15),
2 SEA_BUF_LNG FIXED BINARY(15),
2 VAL_BUF_LNG FIXED BINARY(15),
2 ISN_BUF_LNG FIXED BINARY(15),
2 CMD_OPT_1 CHAR(1),
2 CMD_OPT_2 CHAR(1),
2 ADDITIONS_1 CHAR(8),
2 ADDITIONS_2 CHAR(4),
2 ADDITIONS_3 CHAR(8),
2 ADDITIONS_4 CHAR(8),
2 ADDITIONS_5 CHAR(8),
2 COMMAND_TIME FIXED BINARY(31),
2 USER_AREA CHAR(4) ;
/************************************
* ADABAS Format and Record Buffer *
************************************/
DCL FB CHAR(8) INIT ('ASN,4,P.') ;
DCL OPENRB CHAR(7) INIT ('UPD=11.') ;
DCL RB CHAR(4) ;
DCL SALARY FIXED DECIMAL(7) BASED (ADDR(RB)) ;
DCL OLD_SALARY FIXED DECIMAL(7);
/**********************************
* ADABAS Search and Value Buffer *
**********************************/
DCL SB CHAR(5) INIT ('AE,5.') ;
DCL VB CHAR(5) INIT ('SMITH') ;
/*********************
* ADABAS ISN Buffer *
*********************/
DCL IB(1) FIXED BINARY(31) ;
vms /***********
* Counter *
***********/
DCL UPD FIXED BINARY(15) INIT(0) ;
/**************************
* Write startup message *
***************************/
PUT SKIP EDIT ('PL/1 example program for calling ADABAS') (A);
/******************
* Open database *
******************/
COMMAND_CODE= 'OP' ;
DB_ID = BYTE(EXAMPLE_DB) ;
REC_BUF_LNG = LENGTH(OPENRB) ;
CALL ADABAS (CB,,OPENRB) ;
IF RESPONSE_CODE=9 THEN
CALL ADABAS (CB,,OPENRB) ;
IF RESPONSE_CODE ^= 0 THEN GOTO ERR30 ;
/*****************
* Initial find *
*****************/
COMMAND_CODE= 'S4' ;
COMMAND_ID = 'FIND' ;
FILE_NUMBER = BYTE(EMPLOYEES_FILE) ;
FMT_BUF_LNG = LENGTH(FB) ;
REC_BUF_LNG = LENGTH(RB) ;
SEA_BUF_LNG = LENGTH(SB) ;
VAL_BUF_LNG = LENGTH(VB) ;
ISN_BUF_LNG = HBOUND(IB,1)*4 ;
CMD_OPT_1 = ' ' ;
CMD_OPT_2 = 'N' ;
CALL ADABAS (CB,FB,RB,SB,VB,IB) ;
IF RESPONSE_CODE ^= 0 THEN GOTO ERR30;
PUT SKIP EDIT (' Found: ',cb.isn_quantity,' records' ) (A,F(4),A);
IF ISN_QUANTITY = 0 THEN GOTO ERR20 ;
/**************************************
* Change the value for field SALARY *
* and update record *
**************************************/
CON10:
OLD_SALARY = SALARY ;
SALARY = SALARY + (SALARY * 0.1 ) ;
COMMAND_CODE= 'A1' ;
CALL ADABAS (CB,FB,RB);
IF RESPONSE_CODE ^= 0 THEN GOTO ERR10;
PUT SKIP EDIT (' ISN= ' ,CB.ISN,' old salary= ',
old_salary,' new salary= ',salary)(A) ;
UPD = UPD + 1 ;
COMMAND_CODE = 'L4' ;
CALL ADABAS (CB,FB,RB,SB,VB,IB) ;
IF RESPONSE_CODE = 0 THEN GOTO CON10 ;
IF RESPONSE_CODE = 3 THEN GOTO ERR20 ;
/***********************
* Backout transaction *
***********************/
ERR10:
PUT SKIP EDIT ('**Response code ',response_code,'from ADABAS for
command' ,COMMAND_CODE) (A) ;
IF UPD = 0 THEN GOTO ERR20 ;
COMMAND_CODE = 'BT' ;
CALL ADABAS (CB) ;
IF RESPONSE_CODE ^= 0 THEN GOTO ERR30 ;
UPD = 0 ;
/******************
* Close database *
******************/
ERR20:
COMMAND_CODE = 'CL' ;
CALL ADABAS (CB) ;
IF RESPONSE_CODE ^= 0 THEN GOTO ERR30 ;
GOTO EXIT ;
/**********************
* Print response code *
**********************/
ERR30:
PUT SKIP EDIT ('** Response code ',response code,'from ADABAS for
command',COMMAND_CODE) (A) ;
EXIT:
END EXAMPLE ;