1 OPTION TYPE = EXPLICIT, SIZE = INTEGER LONG REM **************************************************** Deptbas.rba: This program defines an index on department code and a constraint on department manager. It then stores a new department and modifies the current department codes of employees who have been moved to the new department. It calls Getsuper.rba to write out the supervisory tree of each employee in the new dept. It then deletes the index and constraint. Note: This program is intended to give a picture of the department organization IF certain departments are created. For this reason, the program modifies the current JOB_HISTORY record of the employee instead of storing a new JOB_HISTORY record, and rolls back the transaction instead of committing it. **************************************************** 10 DECLARE INTEGER Ok, !success/failure flag & Emp, !index for employee id array & Exists, !stores results of GET COUNT queries & Rec_found, !flag to test FOR loop retrieval & Arg, !argument to pass to interpreter & Arg_num !num of arguments to pass to interpreter DECLARE STRING Rdb_string, & Dept_code, & Dept_name, & Last_name, & Id, & Emp_name, & Manag_id, & Super_id, & Manag_dept, & Super_dept !define buffer for input file: MAP (Input_buf) STRING Space = 1, & New_dept_code = 4, & New_dept_name = 30, & New_manag_id = 5, & Emp_ids(19) = 5 !array of employee ids MAP (Input_buf) STRING Space = 1, & Test = 1 !test character !other declarations DECLARE STRING CONSTANT Null = "" DECLARE INTEGER CONSTANT True = -1% DECLARE INTEGER CONSTANT In_file = 1% DECLARE INTEGER CONSTANT Out_file = 2% DECLARE INTEGER CONSTANT Error_file = 3% DECLARE INTEGER CONSTANT Trim_blanks = 128% !program subprograms EXTERNAL SUB Rdb_error !evaluates rdb errors using Rdb$MESSAGE_VECTOR EXTERNAL SUB Rdb_interp (STRING, INTEGER, INTEGER) !calls RDB$INTERPRET EXTERNAL INTEGER FUNCTION Getsuper (STRING) !gets supervisor info !invoke database in precompiled &RDB& INVOKE DATABASE GLOBAL Pers = &RDB& FILENAME 'RDM$DEMO:personnel' !begin program logic 20 ON ERROR GO TO Basic_error !open error file and write heading OPEN 'RDM$DEMO:Deptbas.err' FOR OUTPUT AS #Error_file PRINT #Error_file, 'Deptbas.rba Error File' !invoke database in callable and start transaction Rdb_string = 'invoke database !val = filename ' + & '"RDM$DEMO:personnel"' !call subroutine Rdb_interp that calls RDB$INTERPRET !Arg_num equals number of arguments to pass database Arg_num = 1% CALL Rdb_interp(Rdb_string, Pers, Arg_num) Arg_num = 0% Rdb_string = 'start_transaction read_write' CALL Rdb_interp(Rdb_string, Arg, Arg_num) !define constraint manag_id_exists using sub- !routine Rdb_interp that calls RDB$INTERPRET Rdb_string = 'define constraint manag_id_exists ' + & 'for d in departments ' + & 'require any e in employees with ' + & 'e.employee_id = d.manager_id ' + & 'check on update.' CALL Rdb_interp(Rdb_string, Arg, Arg_num) Rdb_string = 'commit' CALL Rdb_interp(Rdb_string, Arg, Arg_num) !open input file, open output file and write heading 100 Begin_process: OPEN 'RDM$DEMO:Newdepts.dat' FOR INPUT AS #In_file, & MAP Input_buf OPEN 'RDM$DEMO:Deptbas.lst' FOR OUTPUT AS #Out_file PRINT #Out_file, 'Deptbas.rba Output File' !begin Rdb precompiled logic &RDB& START_TRANSACTION READ_WRITE RESERVING &RDB& DEPARTMENTS, JOB_HISTORY FOR EXCLUSIVE WRITE, &RDB& EMPLOYEES FOR SHARED WRITE &RDB& ON ERROR CALL Rdb_error CLOSE #In_file GO TO Begin_process !try again &RDB& END_ERROR 200 Create_new_dept: WHILE TRUE GET #In_file !get an input record SELECT Test CASE 'A' TO 'Z', 'a' TO 'z' !a new dept record, do nothing CASE ELSE !not a dept record, terminate prog PRINT 'Invalid input file, terminating Deptbas.rba' PRINT #Error_file, 'Invalid input file, terminating Deptbas.rba' GO TO Clean_up END SELECT &RDB& GET !see if new dept already exists &RDB& ON ERROR CALL Rdb_error &RDB& ROLLBACK !deadlock or lock conf CLOSE #In_file CLOSE #Out_file GO TO Begin_process !try again &RDB& END_ERROR &RDB& Exists = COUNT OF D IN DEPARTMENTS WITH &RDB& D.DEPARTMENT_CODE = New_dept_code &RDB& END_GET SELECT Exists CASE > 0 !new dept does exist PRINT #Out_file, 'Department ';New_dept_code; & ' already exists' CASE ELSE !new dept doesn't exist, store it &RDB& STORE D IN DEPARTMENTS USING &RDB& ON ERROR CALL Rdb_error &RDB& ROLLBACK !deadlock or lock conf CLOSE #In_file CLOSE #Out_file GO TO Begin_process !try again &RDB& END_ERROR &RDB& D.DEPARTMENT_CODE = New_dept_code; &RDB& D.DEPARTMENT_NAME = New_dept_name; &RDB& D.MANAGER_ID = New_manag_id &RDB& END_STORE !process each new employee id in array until no more ids FOR Emp = 0% TO 59% IF Emp_ids(Emp) = Null !end of array THEN GO TO Print_higher_ups !get out of loop END IF !modify emp's dept code Rec_found = 0% !clear flag to test retrieval &RDB& FOR E IN EMPLOYEES CROSS JH IN JOB_HISTORY &RDB& WITH JH.JOB_END MISSING &RDB& AND JH.EMPLOYEE_ID = E.EMPLOYEE_ID &RDB& AND E.EMPLOYEE_ID = Emp_ids(Emp) &RDB& ON ERROR CALL Rdb_error &RDB& ROLLBACK !deadlock or lock conf CLOSE #In_file CLOSE #Out_file GO TO Begin_process !try again &RDB& END_ERROR &RDB& MODIFY JH USING &RDB& ON ERROR CALL Rdb_error &RDB& ROLLBACK !deadlock or lock conf CLOSE #In_file CLOSE #Out_file GO TO Begin_process !try again &RDB& END_ERROR &RDB& JH.DEPARTMENT_CODE = New_dept_code &RDB& END_MODIFY Rec_found = 1% !set flag &RDB& END_FOR IF (Rec_found = 0) THEN PRINT 'No record found on modify' PRINT #Error_file, 'No record found on modify' END IF NEXT Emp END SELECT !print the supervisory ladder for everyone in new dept Print_higher_ups: Rec_found = 0% !clear flag to test retrieval &RDB& FOR CJ IN CURRENT_JOB WITH &RDB& CJ.DEPARTMENT_CODE = NEW_DEPT_CODE &RDB& ON ERROR CALL Rdb_error &RDB& ROLLBACK !deadlock or lock conf CLOSE #In_file CLOSE #Out_file GO TO Begin_process !try again &RDB& END_ERROR &RDB& GET &RDB& ON ERROR CALL Rdb_error &RDB& ROLLBACK !deadlock or lock conf CLOSE #In_file CLOSE #Out_file GO TO Begin_process !try again &RDB& END_ERROR &RDB& Id = CJ.EMPLOYEE_ID; &RDB& Emp_name = CJ.LAST_NAME &RDB& END_GET Rec_found = 1% !set flag PRINT 'Printing supervisors for employee '; & EDIT$(Emp_name, Trim_blanks); ' in department '; & New_dept_name PRINT #Out_file, 'Supervisors for employee '; Emp_name PRINT #Out_file, ' in department '; & EDIT$(New_dept_name, Trim_blanks); ':' Ok = Getsuper(Id) IF (NOT Ok) !deadlock or lock conflict THEN GO TO Begin_process !try again END IF &RDB& END_FOR IF (Rec_found = 0) THEN PRINT 'No record found on GET for '; Emp_name PRINT #Error_file, 'No record found on GET for '; Emp_name END IF NEXT !go get next input record !close file and end transaction 300 All_done: CLOSE #In_file &RDB& ROLLBACK &RDB& ON ERROR CALL Rdb_error &RDB& END_ERROR ! delete constraint manag_id_exists using sub- ! routine Rdb_interp that calls RDB$INTERPRET 400 Arg_num = 0% Rdb_string = 'start_transaction read_write' CALL Rdb_interp(Rdb_string, Arg, Arg_num) Rdb_string = 'delete constraint manag_id_exists.' CALL Rdb_interp(Rdb_string, Arg, Arg_num) Rdb_string = 'commit' CALL Rdb_interp(Rdb_string, Arg, Arg_num) Rdb_string = 'finish' CALL Rdb_interp(Rdb_string, Arg, Arg_num) GO TO Clean_up 500 Basic_error: !error routine for BASIC errors SELECT ERR CASE 11 !end of file RESUME 300 CASE ELSE PRINT #Error_file, 'BASIC error '; ERR; 'on line '; ERL PRINT #Error_file, 'with error message:' PRINT #Error_file, ERT$(ERR) PRINT 'BASIC error '; ERR; 'on line '; ERL; & ' with error message:' PRINT ERT$(ERR) RESUME 1000 END SELECT 1000 Clean_up: CLOSE #Out_file CLOSE #Error_file 1100 End_prog: PRINT 'Deptbas.rba end' END 5000 SUB Rdb_interp (STRING Rdb_string, INTEGER Arg, Arg_num) 5001 OPTION TYPE = EXPLICIT, SIZE = INTEGER LONG REM ************************************************ This subroutine calls RDB$INTERPRET. Arg_num is the number of !val arguments that RDB$INTERPRET passes to the database. The subroutine evaluates the condition value returned by RDB$INTERPRET and performs the necessary error handling. ************************************************ 5010 DECLARE LONG Stat, & Err_match DECLARE STRING Msg_string DECLARE INTEGER CONSTANT TRUE = -1% DECLARE INTEGER CONSTANT FALSE = 0% DECLARE INTEGER CONSTANT Error_file = 3% EXTERNAL INTEGER FUNCTION RDB$INTERPRET EXTERNAL INTEGER FUNCTION RDB$SIGNAL EXTERNAL INTEGER FUNCTION LIB$MATCH_COND EXTERNAL INTEGER FUNCTION SYS$GETMSG !errors to handle: EXTERNAL INTEGER CONSTANT RDO$_CONALREXI !constraint already defined EXTERNAL INTEGER CONSTANT RDB$_NO_META_UPDATE !no metadata update ! begin subroutine logic 5020 SELECT Arg_num CASE 0% !call interpreter with no arguments Stat = RDB$INTERPRET(Rdb_string BY DESC) CASE 1% !call interpreter with 1 argument Stat = RDB$INTERPRET(Rdb_string BY DESC, Arg BY DESC) END SELECT SELECT (Stat AND 1%) <> 0 CASE TRUE !call was successful EXIT SUB !continue main module logic CASE FALSE Err_match = LIB$MATCH_COND(Stat BY REF, & RDO$_CONALREXI BY REF, & RDB$_NO_META_UPDATE BY REF) SELECT Err_match CASE 1%, 2% PRINT 'Non-fatal error, constraint exists' CALL SYS$GETMSG(Stat BY REF,,Msg_string BY DESC) PRINT #Error_file, 'Non-fatal error, constraint exists' PRINT #Error_file, Msg_string !print the error message EXIT SUB !continue main module logic CASE 0% PRINT 'Fatal RDB$INTERPRET error, terminating Deptbas.rba' PRINT #Error_file, & 'Fatal RDB$INTERPRET error, terminating Deptbas.rba' CALL RDB$SIGNAL() !print error message to term and quit END SELECT END SELECT END SUB 7000 SUB Rdb_error 7001 OPTION TYPE = EXPLICIT, SIZE = INTEGER LONG REM ************************************************ This routine handles all precompiled Rdb errors; deadlock and lock conflict print a message and return to the ON ERROR clause which rolls back the database. All other errors are passed to LIB$SIGNAL and the program is terminated. ************************************************ 7010 DECLARE LONG Stat, & Err_match, & Error_stat DECLARE STRING Error_mess DECLARE INTEGER CONSTANT Error_file = 3% !declare Rdb$MESSAGE_VECTOR COMMON (Rdb$MESSAGE_VECTOR) INTEGER Rdb$MESSAGE_VECTOR, & Rdb$LU_STATUS, Rdb$ALU_ARGUMENTS(17) !possible errors to trap for: EXTERNAL INTEGER CONSTANT RDB$_LOCK_CONFLICT !lock conflict EXTERNAL INTEGER CONSTANT RDB$_DEADLOCK !deadlock EXTERNAL INTEGER CONSTANT RDB$_INTEG_FAIL !constraint failed EXTERNAL INTEGER CONSTANT RDB$_NO_CUR_REC !no rec in stream EXTERNAL INTEGER CONSTANT RDB$_NO_RECORD !rec was deleted EXTERNAL INTEGER CONSTANT RDB$_UNRES_REL !unreserved relation EXTERNAL INTEGER CONSTANT RDB$_READ_ONLY_VIEW !update through view EXTERNAL INTEGER CONSTANT RDB$_REQ_NO_TRANS !request after commit !library routines and system functions: EXTERNAL INTEGER FUNCTION LIB$MATCH_COND EXTERNAL INTEGER FUNCTION LIB$SIGNAL EXTERNAL INTEGER FUNCTION SYS$GETMSG ! begin subroutine logic 7020 Stat = LIB$MATCH_COND (Rdb$LU_STATUS BY REF, & RDB$_LOCK_CONFLICT, & RDB$_DEADLOCK, & RDB$_INTEG_FAIL, & RDB$_NO_CUR_REC, & RDB$_NO_RECORD, & RDB$_UNRES_REL, & RDB$_READ_ONLY_VIEW, & RDB$_REQ_NO_TRANS) SELECT Stat CASE 1% !print message and return PRINT 'Lock conflict, rolling back transaction' PRINT #Error_file, 'Lock conflict, rolling back transaction' CASE 2% !print message and return PRINT 'Deadlock, rolling back transaction' PRINT #Error_file, 'Deadlock, rolling back transaction' CASE 3% TO 8% !print message and quit Error_stat = SYS$GETMSG(Rdb$LU_STATUS BY REF,,Error_mess BY DESC) PRINT 'Deptbas.rba expected error: '; Error_mess; & ' - terminating program' PRINT #Error_file, 'Deptbas.rba expected error: '; & Error_mess; ' - terminating program' CALL LIB$SIGNAL BY VALUE(Rdb$LU_STATUS) !monitor will do rollback CASE 0% !print message and quit Error_stat = SYS$GETMSG(Rdb$LU_STATUS BY REF,,Error_mess BY DESC) PRINT 'Deptbas.rba unexpected error: '; Error_mess; & ' - terminating program' PRINT #Error_file, 'Deptbas.rba unexpected error: '; & Error_mess; ' - terminating program' CALL LIB$SIGNAL BY VALUE(Rdb$LU_STATUS) !monitor will do rollback END SELECT END SUB