Adabas ダイレクトコールを使用する VAX-11 BASIC の例です。付録 B で定義された Adabas ファイルが使用されています。
!*********************************************************
!* *
!* A D A B A S / V M S BASIC example program *
!* --------------------------------------------- *
!* *
!* Compile, link and run this program by typing: *
!* *
!* $ BASIC EXAMPLE *
!* $ LINK EXAMPLE,ADABAS$VERSION:ADABAS.OLB/LIB *
!* $ RUN EXAMPLE *
!* *
!* Function: *
!* Find in the default database all people *
!* named 'SMITH' and increase their salary *
!* by 10% *
!* *
!*********************************************************
DECLARE STRING EXAMPLE_DB \ EXAMPLE_DB = CHR$(0)
DECLARE STRING EMPLOYEES_FILE \ EMPLOYEES_FILE = CHR$(11)
!**************************
!* ADABAS Control Block *
!**************************
MAP (CONT_BLOCK) STRING CB = 80
MAP (CONT_BLOCK) STRING FILLER1 = 2, &
COMMAND_CODE = 2, &
COMMAND_ID = 4, &
FILE_NUMBER = 1, &
DB_ID = 1, &
WORD RESPONSE_CODE, &
LONG ISN, &
ISN_LL, &
ISN_QUANTITY, &
WORD FMT_BUF_LNG, &
REC_BUF_LNG, &
SEA_BUF_LNG, &
VAL_BUF_LNG, &
ISN_BUF_LNG, &
STRING CMD_OPT_1 = 1, &
CMD_OPT_2 = 1, &
ADDITIONS_1 = 8, &
ADDITIONS_2 = 4, &
ADDITIONS_3 = 8, &
ADDITIONS_4 = 8, &
ADDITIONS_5 = 8, &
LONG COMMAND_TIME, &
STRING USER_AREA = 4
!*************************************
!* ADABAS Format and Record Buffer *
!*************************************
DECLARE STRING FB \ FB = 'ASN,4,F.'
DECLARE STRING OPENRB \ OPENRB = 'UPD=11.'
MAP (RECORD_BUF) STRING RB = 4
MAP (RECORD_BUF) LONG SALARY
DECLARE LONG OLD_SALARY
!************************************
!* ADABAS Search and Value Buffer *
!************************************
DECLARE STRING SB \ SB = 'AE,5.'
DECLARE STRING VB \ VB = 'SMITH'
!***********************
!* ADABAS ISN buffer *
!***********************
DECLARE LONG IB
!*************
!* Counter *
!*************
DECLARE INTEGER UPD \ UPD = 0
!***************************
!* Write startup message *
!***************************
900 PRINT ' BASIC example program for calling ADABAS (OpenVMS)'
!*******************
!* Open database *
!*******************
COMMAND_CODE = 'OP'
DB_ID = EXAMPLE_DB
REC_BUF_LNG = LEN(OPENRB)
950 CALL ADABAS (CB BY REF,,OPENRB BY REF) 960 IF RESPONSE_CODE = 9 THEN GOTO 950 970 IF RESPONSE_CODE <> 0 THEN GOTO 4000
ELSE
!******************
!* Initial find *
!******************
COMMAND_CODE = 'S4'
COMMAND_ID = 'FIND'
FILE_NUMBER = EMPLOYEES_FILE
FMT_BUF_LNG = LEN(FB)
REC_BUF_LNG = LEN(RB)
SEA_BUF_LNG = LEN(SB)
VAL_BUF_LNG = LEN(VB)
ISN_BUF_LNG = 4
CMD_OPT_1 = ' '
CMD_OPT_2 = 'N'
CALL ADABAS (CB BY REF,READFB BY REF,RB BY REF,SB BY REF,
VB BY REF,IB BY REF)
IF RESPONSE_CODE <> 0 THEN GOTO 2000
ELSE PRINT 'Found : ';ISN_QUANTITY;' records'
IF ISN_QUANTITY = 0 THEN GOTO 3000
!************************************
!* Loop over all selected records *
!************************************
1000 OLD_SALARY = SALARY
SALARY = SALARY + (SALARY * 0.1)
COMMAND_CODE = 'A1'
CALL ADABAS (CB YB REF, FB BY REF, RB BY REF)
1010 IF RESPONSE_CODE <> 0 THEN GOTO 2000
1020 PRINT ' ISN=';ISN;' old salary = ';OLD_SALARY;' new salary = ';NEW
SALARY
UPD = UPD + 1
COMMAND_CODE = 'L4'
CALL ADABAS (CB BY REF, FB BY REF, RB BY REF)
1030 IF RESPONSE_CODE = 0 THEN GOTO 1000 1040 IF RESPONSE_CODE = 3 THEN GOTO 3000
!***********************
!* Backout transaction *
!***********************
2000 PRINT '**Response code ';RESPONSE_CODE;' from ADABAS for command
';COMMAND_ID
2010 IF UPD = 0 THEN GOTO 3000
2020 COMMAND_CODE = 'BT'
CALL ADABAS (CB BY REF)
2030 IF RESPONSE_CODE <> 0 THEN GOTO 4000
ELSE
UPD = 0
!********************
!* Close database *
!********************
3000 COMMAND_CODE = 'CL'
CALL ADABAS (CB BY REF)
3010 IF RESPONSE_CODE <> 0 THEN GOTO 4000
ELSE
GOTO 5000
!*************************
!* Print response code *
!*************************
4000 PRINT ' ** Response code ';RESPONSE_CODE;from ADABAS for command
';COMMAND_ID
!***********************
!* Common exit point *
!***********************
5000 END