* Copyright © Oracle Corporation 1995. All Rights Reserved. ************************************************************************* * This is the main program that calls all the sample COBOL subroutines * together. It allows the user to choose among serveral actions * on the database. * * To create an executable image of all the modules, * enter the following series of commands: * * * $ rcob :== $rdbpre/cobol * $ rcob cob_sample * $ rcob cob_call_other * $ rcob cob_callable_error_handler * * $ link cob_sample, cob_call_other, cob_callable_error_handler * * $ run cob_sample ***************************************************************************** IDENTIFICATION DIVISION. PROGRAM-ID. Sample. ENVIRONMENT DIVISION. INPUT-OUTPUT SECTION. FILE-CONTROL. SELECT resume_file ASSIGN SYS$DISK. DATA DIVISION. FILE SECTION. FD resume_file VALUE OF ID IS file-name. 01 resume_line PIC X(80). WORKING-STORAGE SECTION. &RDB& DATABASE GLOBAL pers = FILENAME "MF_PERSONNEL" DBKEY SCOPE IS FINISH 01 end_of_emps_flag PIC X. 88 end_of_emps VALUE 'Y'. 01 end_of_cands_flag PIC X. 88 end_of_cands VALUE 'Y'. 01 employees. 02 employee_id PIC X(5). 88 want_to_exit VALUE "EXIT", "exit". 02 last_name PIC X(14). 02 first_name PIC X(10). 02 middle_initial PIC X. 02 address_data_1 PIC X(25). 02 address_data_2 PIC X(25). 02 city PIC X(20). 02 state PIC X(2). 02 postal_code PIC X(5). 02 birthday PIC S9(11)V9(7) COMP. 01 degrees. 02 demployee_id PIC X(5). 02 dcollege_code PIC X(4). 02 year_given PIC S9(4) COMP. 02 degree PIC X(3). 02 degree_field PIC X(15). 01 salary_history. 02 salary_start PIC S9(11)V9(7) COMP. 01 colleges. 02 college_code PIC X(4). 02 college_name PIC X(25). 02 college_city PIC X(20). * Declare variables to hold information for the CANDIDATES relation; * candidate_status is a variable to hold a value * for a field that is of VARYING STRING data type. * However, COBOL does not support VARYING STRING data types, so * declare a string that matches the maximum size of a VARYING STRING. 01 candidates. 02 candidate_last_name PIC X(14). 02 candidate_first_name PIC X(10). 02 candidate_middle_initial PIC X. 02 candidate_status PIC X(257). 01 option PIC S9(4) COMP. 01 response PIC X. 01 more_responses_flag PIC X(3). 88 no_more_responses VALUE "NO". 01 confirm_flag PIC X. 88 confirm VALUE "Y","y". 01 success_flag PIC X. 88 successful VALUE "Y". 01 see_all_flag PIC X. 88 want_to_see_all VALUE "Y","y". 01 found_employee_flag PIC X. 88 found_employee VALUE "Y". 01 found_candidate_flag PIC X. 88 found_candidate VALUE "Y". 01 eof_flag PIC X. 88 end_of_file VALUE "Y". 01 continue_key PIC X. * ASCII date to be input and converted to binary date (birthday). 01 ascii_date PIC X(23). 01 size_of_ascii_date PIC S9(4) COMP VALUE 23. 01 return_status PIC S9(9) COMP. 01 valid_date_flag PIC X(3). 88 valid_date VALUE "YES". 01 data_base_key PIC X(8). 01 dbkey_array. 05 database_key PIC X(8) OCCURS 100 TIMES. 01 number_employees_added PIC S9(4) COMP VALUE 0. 01 i PIC S9(4) COMP VALUE 0. 01 db_key PIC X(8). 01 counter PIC S9(4) COMP VALUE 0. 01 number_of_employees PIC 9(5). 01 file-name PIC X(20). 01 ddl_statement PIC X(256). 88 no_more_ddl_statements VALUE "EXIT", "exit". * Used in display resume. 01 resume_segment PIC X(80). 01 segment_length PIC S9(4) COMP. 01 retry_count PIC S9(4) COMP VALUE 0. 01 lock_error_flag PIC X. 88 lock_error VALUE 'Y'. 01 transaction_started_flag PIC X. 88 transaction_started VALUE 'Y'. 01 dbhandle PIC S9(9) COMP. 01 trans1 PIC S9(9) COMP. PROCEDURE DIVISION. * Display menu of choices to user. Display_menu. PERFORM UNTIL no_more_responses DISPLAY "" LINE 1 COLUMN 1 ERASE TO END OF SCREEN DISPLAY " Main Menu" DISPLAY " Sample Application" DISPLAY SPACE DISPLAY "1. Add one or more records to EMPLOYEES" DISPLAY "2. Modify the address of one or more records in EMPLOYEES" DISPLAY "3. Delete one or more records from EMPLOYEES" DISPLAY "4. List all the EMPLOYEES and the COLLEGES attended" DISPLAY "5. List employees in order of Seniority" DISPLAY "6. Pair an EMPLOYEES record with a CANDIDATES record" DISPLAY "7. Calculate the total number of EMPLOYEES in the company" DISPLAY "8. Store one or more records in the CANDIDATES relation" DISPLAY "9. Display one or more records from CANDIDATES" DISPLAY "10. Display employee IDs of employees in DEGREES with - " an unknown area of study" DISPLAY "11. Store a record in DEGREES" DISPLAY "12. Modify a resume in RESUMES" DISPLAY "13. Display a RESUME" DISPLAY "14. Add or delete a temporary index" DISPLAY "15. Retrieve COLLEGES information using Callable RDO" DISPLAY "16. Store a RESUME" DISPLAY "99. Exit the Program" DISPLAY "Please enter an option number and press RETURN: " LINE 22 COLUMN 1 NO ADVANCING ACCEPT option WITH CONVERSION PROTECTED REVERSED * The COBOL EVALUATE statement directs program to perform appropriate * procedures based on user's response the the preceding menu. EVALUATE option WHEN 1 PERFORM Add_employees WHEN 2 PERFORM Modify_address WHEN 3 PERFORM Delete_record WHEN 4 PERFORM List_record WHEN 5 PERFORM Seniority WHEN 6 PERFORM Pair WHEN 7 PERFORM Stats WHEN 8 PERFORM Store_cand WHEN 9 PERFORM Display_cand WHEN 10 PERFORM Find_missing WHEN 11 PERFORM Rdbdollarmissing WHEN 12 PERFORM Mod_resume WHEN 13 PERFORM Display_resume WHEN 14 PERFORM Ddl_stmnt WHEN 15 PERFORM Callable WHEN 16 PERFORM Store_res WHEN 99 MOVE "NO" TO more_responses_flag WHEN OTHER DISPLAY "Invalid entry" END-EVALUATE END-PERFORM &RDB& FINISH STOP RUN. Add_employees. ****************************************************************** * This procedure adds a new EMPLOYEES record to the EMPLOYEES * * relation. * ****************************************************************** DISPLAY SPACE LINE 1 COLUMN 1 ERASE TO END OF SCREEN DISPLAY "Add Employees" LINE 1 COLUMN 20 DISPLAY "" LINE 2 COLUMN 1 * Prompt user for input, until user enters 'exit'. DISPLAY "Please enter the ID of the new employee or type exit: " NO ACCEPT employee_id PROTECTED REVERSED PERFORM UNTIL want_to_exit INITIALIZE confirm_flag, retry_count, success_flag PERFORM until confirm DISPLAY "Please enter the employee's last name: " NO ADVANCING ACCEPT last_name PROTECTED REVERSED DISPLAY "Please enter the employee's first name: " NO ADVANCING ACCEPT first_name PROTECTED REVERSED DISPLAY "Please enter the employee's middle initial: " NO ADVANCING ACCEPT middle_initial PROTECTED REVERSED INITIALIZE valid_date_flag * Prompt user to input date, keep prompting until user * enters the date in the proper format. PERFORM UNTIL valid_date DISPLAY "Please enter the employee's birthday (dd-MMM-yyyy):" WITH NO ADVANCING ACCEPT ascii_date PROTECTED REVERSED * Use SYS$BINTIM to convert ASCII input to binary format. CALL "SYS$BINTIM" USING BY DESCRIPTOR ascii_date BY REFERENCE birthday GIVING return_status IF return_status IS FAILURE THEN DISPLAY "Invalid date format" ELSE MOVE "YES" TO valid_date_flag END-IF END-PERFORM DISPLAY "Please enter the employee's street address: " NO ADVANCING ACCEPT address_data_1 PROTECTED REVERSED DISPLAY "Please enter apartment number, if any: " WITH NO ADVANCING ACCEPT address_data_2 PROTECTED REVERSED DISPLAY "Please enter city: " WITH NO ADVANCING ACCEPT city PROTECTED REVERSED DISPLAY "Please enter state: " WITH NO ADVANCING ACCEPT state PROTECTED REVERSED DISPLAY "Please enter postal code: " WITH NO ADVANCING ACCEPT postal_code PROTECTED REVERSED DISPLAY "Have you entered all data correctly? (Y/N): " NO ADVANCING ACCEPT confirm_flag PROTECTED REVERSED END-PERFORM * The following loop will execute at least once, because 'success' is * set to false, and 'retry_count' to zero. If an error occurs during * the START_TRANSACTION operation, the program will retry this * operation up to 5 times. INITIALIZE retry_count, lock_error_flag, transaction_started_flag PERFORM WITH TEST AFTER UNTIL (lock_error AND retry_count = 5) OR (successful) OR (NOT lock_error) MOVE 'Y' TO success_flag, transaction_started_flag INITIALIZE lock_error_flag &RDB& START_TRANSACTION READ_WRITE NOWAIT RESERVING &RDB& EMPLOYEES FOR SHARED WRITE &RDB& ON ERROR MOVE "N" TO success_flag, transaction_started_flag CALL "Error_handler" USING RDB$STATUS, retry_count, success_flag, lock_error_flag &RDB& END_ERROR * The following loop will execute at least once if the START_TRANSACTION * was successful. If an error occurs during the STORE operation, the * program will retry the STORE operation up to 5 times. IF NOT lock_error THEN INITIALIZE retry_count, lock_error_flag PERFORM WITH TEST AFTER UNTIL (lock_error AND retry_count = 5) OR successful OR NOT lock_error MOVE 'Y' TO success_flag INITIALIZE lock_error_flag &RDB& STORE E IN EMPLOYEES USING &RDB& ON ERROR MOVE "N" TO success_flag CALL "Error_handler" USING RDB$STATUS, retry_count, success_flag, lock_error_flag &RDB& END_ERROR * Store the values that the user entered in an EMPLOYEES record. &RDB& E.EMPLOYEE_ID = employee_id; &RDB& E.LAST_NAME = last_name; &RDB& E.FIRST_NAME = first_name; &RDB& E.MIDDLE_INITIAL = middle_initial; &RDB& E.ADDRESS_DATA_1 = address_data_1; &RDB& E.ADDRESS_DATA_2 = address_data_2; &RDB& E.CITY = city; &RDB& E.STATE = state; &RDB& E.POSTAL_CODE = postal_code; &RDB& E.BIRTHDAY = birthday * Get the dbkey associated with the newly stored EMPLOYEES record. &RDB& GET &RDB& ON ERROR MOVE "N" TO success_flag &RDB& END_ERROR &RDB& data_base_key = E.RDB$DB_KEY &RDB& END_GET &RDB& END_STORE END-PERFORM END-IF END-PERFORM * If the STORE operation succeeded, increment a counter by one * and add the dbkey to an array of dbkeys. IF successful THEN ADD 1 TO number_employees_added MOVE data_base_key TO database_key(number_employees_added) DISPLAY "Successfully added employee: " last_name DISPLAY "with employee_id: " employee_id DISPLAY SPACE DISPLAY "Do you want to see the names of all the employees entered - " during this session (Y/N): " NO ADVANCING ACCEPT see_all_flag PROTECTED REVERSED * If the user wants to see all the EMPLOYEES records added during this * session, step through the array of dbkeys to find and print * each new EMPLOYEES record. IF want_to_see_all THEN PERFORM VARYING i FROM 1 BY 1 UNTIL i > number_employees_added &RDB& FOR E IN EMPLOYEES WITH E.RDB$DB_KEY = database_key(i) &RDB& ON ERROR MOVE 'N' TO success_flag CALL "Error_handler" USING RDB$STATUS, retry_count, success_flag, lock_error_flag &RDB& END_ERROR &RDB& GET &RDB& ON ERROR MOVE 'N' TO success_flag &RDB& END_ERROR &RDB& employee_id = E.EMPLOYEE_ID; &RDB& last_name = E.LAST_NAME; &RDB& first_name = E.FIRST_NAME; &RDB& middle_initial = E.MIDDLE_INITIAL; &RDB& address_data_1 = E.ADDRESS_DATA_1; &RDB& address_data_2 = E.ADDRESS_DATA_2; &RDB& city = E.CITY; &RDB& state = E.STATE; &RDB& postal_code = E.POSTAL_CODE; &RDB& birthday = E.BIRTHDAY &RDB& END_GET &RDB& END_FOR * If the field values were successfully retrieved, then * convert the date field from binary to a printable (ASCII) format. * The first and last arguments to the call to SYS$ASCTIM are not * required arguments. IF successful THEN PERFORM Display_employee END-IF MOVE 'Y' TO success_flag END-PERFORM END-IF &RDB& COMMIT ELSE DISPLAY "Update operation failed, Employee name ", employee_id, - " has not been stored in the database" IF transaction_started THEN &RDB& ROLLBACK END-IF END-IF DISPLAY "Please enter the ID of the new Employee or type exit: " NO ACCEPT employee_id PROTECTED REVERSED END-PERFORM. Display_employee. DISPLAY SPACE DISPLAY "Employee id: " employee_id DISPLAY "Last name: " last_name DISPLAY "First name: " first_name DISPLAY "Middle init: " middle_initial DISPLAY "Address: " address_data_1, SPACE address_data_2 DISPLAY "City: " city DISPLAY "State: " state DISPLAY "Postal code: " postal_code * Convert binary date to ASCII format. CALL "SYS$ASCTIM" USING BY REFERENCE size_of_ascii_date BY DESCRIPTOR ascii_date BY REFERENCE birthday DISPLAY "Birthday: " ascii_date(1:11) DISPLAY SPACE. Modify_address. **************************************************************** * This subroutine modifies the address of an EMPLOYEES record. * **************************************************************** DISPLAY SPACE LINE 1 COLUMN 1 ERASE TO END OF SCREEN DISPLAY "Modify Employee Address" LINE 1 COLUMN 20 DISPLAY "" LINE 2 COLUMN 1 * Prompt the user for the ID of the employee whose record he or she * wants to modify. DISPLAY "Please enter the ID number of the employee" DISPLAY "whose address you want to change or type exit: " NO ADVANCING ACCEPT employee_id PROTECTED REVERSED PERFORM UNTIL want_to_exit INITIALIZE confirm_flag PERFORM UNTIL confirm OR want_to_exit * Retrieve and display the record specified by the employee ID and confirm * with the user that he or she wants to modify this record. &RDB& START_TRANSACTION READ_WRITE RESERVING EMPLOYEES FOR SHARED READ INITIALIZE found_employee_flag &RDB& FOR E IN EMPLOYEES WITH E.EMPLOYEE_ID = employee_id &RDB& GET &RDB& employee_id = E.EMPLOYEE_ID; &RDB& last_name = E.LAST_NAME; &RDB& first_name = E.FIRST_NAME; &RDB& middle_initial = E.MIDDLE_INITIAL; &RDB& address_data_1 = E.ADDRESS_DATA_1; &RDB& address_data_2 = E.ADDRESS_DATA_2; &RDB& city = E.CITY; &RDB& state = E.STATE; &RDB& postal_code = E.POSTAL_CODE; &RDB& birthday = E.BIRTHDAY &RDB& END_GET PERFORM Display_employee MOVE "Y" TO found_employee_flag &RDB& END_FOR &RDB& COMMIT IF found_employee THEN DISPLAY SPACE DISPLAY "Do you want to change this address (Y/N): " NO ACCEPT confirm_flag PROTECTED REVERSED ELSE DISPLAY "Employee id: ", employee_id, " not on file" END-IF IF (NOT confirm) OR (NOT found_employee) THEN DISPLAY "Please enter the ID number of the employee" DISPLAY "whose address you want to change or exit: " NO ACCEPT employee_id PROTECTED REVERSED END-IF END-PERFORM * Prompt the user for a new address. IF NOT want_to_exit THEN INITIALIZE confirm_flag PERFORM UNTIL confirm DISPLAY "Please enter the street address: " NO ADVANCING ACCEPT address_data_1 PROTECTED REVERSED DISPLAY "Please enter the box number or apartment number: " NO ACCEPT address_data_2 PROTECTED REVERSED DISPLAY "Please enter city: " WITH NO ADVANCING ACCEPT city PROTECTED REVERSED DISPLAY "Please enter state: " WITH NO ADVANCING ACCEPT state PROTECTED REVERSED DISPLAY "Please enter postal code: " WITH NO ADVANCING ACCEPT postal_code PROTECTED REVERSED DISPLAY SPACE DISPLAY "Have you entered the address correctly (Y/N): " NO ACCEPT confirm_flag PROTECTED REVERSED END-PERFORM MOVE 'Y' TO success_flag &RDB& START_TRANSACTION READ_WRITE RESERVING EMPLOYEES FOR SHARED WRITE * Modify the address fields for the specified EMPLOYEES record. &RDB& FOR E IN EMPLOYEES WITH E.EMPLOYEE_ID = employee_id &RDB& MODIFY E USING &RDB& ON ERROR MOVE "N" TO success_flag CALL "Error_handler" USING RDB$STATUS, retry_count, success_flag, lock_error_flag &RDB& END_ERROR &RDB& E.ADDRESS_DATA_1 = address_data_1; &RDB& E.ADDRESS_DATA_2 = address_data_2; &RDB& E.CITY = city; &RDB& E.STATE = state; &RDB& E.POSTAL_CODE = postal_code; &RDB& END_MODIFY &RDB& END_FOR * Notify the user of the success or failure of the modify operation. IF successful THEN DISPLAY "Update operation succeeded" &RDB& COMMIT ELSE DISPLAY "Update operation failed" &RDB& ROLLBACK END-IF DISPLAY "Please enter the ID number of the employee" DISPLAY "whose address you want to change or type exit: " NO ACCEPT employee_id PROTECTED REVERSED END-IF END-PERFORM. Delete_record. ******************************************************* * This subroutine deletes a record from the database. * ******************************************************* DISPLAY SPACE LINE 1 COLUMN 1 ERASE TO END OF SCREEN DISPLAY "Delete Employee" LINE 1 COLUMN 20 DISPLAY "" LINE 2 COLUMN 1 * Prompt the user for the ID of the EMPLOYEES record * that he or she wants to delete * from the database. DISPLAY "Please enter the ID number of the employee" DISPLAY "you want to delete or type exit to return to menu: " NO ADVANCING ACCEPT employee_id PROTECTED REVERSED PERFORM UNTIL want_to_exit INITIALIZE confirm_flag MOVE 'Y' TO success_flag PERFORM until confirm OR want_to_exit &RDB& START_TRANSACTION (TRANSACTION_HANDLE trans1) &RDB& READ_WRITE RESERVING EMPLOYEES FOR SHARED READ * Find the record of the employee that the user wants to delete. If * an error occurs during the FOR operation call an error handler. INITIALIZE found_employee_flag &RDB& FOR (TRANSACTION_HANDLE trans1) &RDB& E IN EMPLOYEES WITH E.EMPLOYEE_ID = employee_id &RDB& ON ERROR MOVE "N" TO success_flag CALL "Error_handler" USING RDB$STATUS, retry_count, success_flag, lock_error_flag &RDB& END_ERROR * Get the dbkey of the EMPLOYEES record that the user wants to delete. &RDB& GET &RDB& ON ERROR MOVE "N" TO success_flag &RDB& END_ERROR &RDB& db_key = E.RDB$DB_KEY &RDB& END_GET MOVE "Y" TO found_employee_flag &RDB& END_FOR IF NOT found_employee THEN DISPLAY "No employee with id: ", employee_id " on file" ELSE IF successful * Pass the dbkey to an external routine "CALL_OTHER" to print * out the record to which the dbkey points. Note that using * an external routine is neither necessary nor recommended for performing * this task. It is done in this example only to show how values are * passed between routines in an RDBPRE COBOL program. THEN CALL "Call_other" USING db_key, trans1 END-IF END-IF &RDB& COMMIT (TRANSACTION_HANDLE trans1) DISPLAY SPACE * Ask user for confirmation that this is the EMPLOYEES * record he or she wants to delete. IF found_employee THEN DISPLAY "Is this the employee you want to delete (Y/N): " NO ACCEPT confirm_flag PROTECTED REVERSED END-IF IF NOT confirm THEN DISPLAY "Employee with employee id: ", employee_id, " not deleted" DISPLAY SPACE END-IF IF (NOT confirm) OR (NOT found_employee) THEN DISPLAY "Please enter the ID number of the Employee" DISPLAY "you want to delete or type exit to return to menu: " NO ACCEPT employee_id PROTECTED REVERSED END-IF END-PERFORM IF NOT want_to_exit THEN * If the user wants to delete the EMPLOYEES record, then * start a READ_WRITE transaction and delete the EMPLOYEES * record from all relations in which its employee_id appears. * Note that this is all done in one transaction. * You would not want to split this task across transactions. If one * of the many transactions failed, you would not be certain that the * employee's records were deleted from all of the relations. &RDB& START_TRANSACTION READ_WRITE RESERVING EMPLOYEES, &RDB& SALARY_HISTORY, JOB_HISTORY, DEPARTMENTS, &RDB& DEGREES, WORK_STATUS, RESUMES FOR SHARED WRITE &RDB& FOR E IN EMPLOYEES WITH E.RDB$DB_KEY = db_key &RDB& FOR JH IN JOB_HISTORY WITH JH.EMPLOYEE_ID = E.EMPLOYEE_ID &RDB& ERASE JH &RDB& END_FOR &RDB& FOR SH IN SALARY_HISTORY WITH SH.EMPLOYEE_ID = E.EMPLOYEE_ID &RDB& ERASE SH &RDB& END_FOR &RDB& FOR D IN degrees WITH D.EMPLOYEE_ID = E.EMPLOYEE_ID &RDB& ERASE D &RDB& END_FOR &RDB& FOR R IN RESUMES WITH R.EMPLOYEE_ID = E.EMPLOYEE_ID &RDB& ERASE R &RDB& END_FOR &RDB& ERASE E DISPLAY "Employee id: ", employee_id, " deleted successfully" &RDB& END_FOR &RDB& COMMIT DISPLAY "Please enter the ID number of the Employee" DISPLAY "you want to delete or type exit to return to menu: " NO ACCEPT employee_id PROTECTED REVERSED END-IF END-PERFORM. List_record. ************************************************************************** * This procedure lists all the employees and the colleges they attended. * ************************************************************************** DISPLAY SPACE LINE 1 COLUMN 1 ERASE TO END OF SCREEN DISPLAY "List of employees and colleges attended" LINE 1 COLUMN 20 DISPLAY "" LINE 2 COLUMN 1 &RDB& START_TRANSACTION READ_ONLY * For each EMPLOYEES record that has a corresponding record in DEGREES, * print the DEGREES record. &RDB& FOR E IN EMPLOYEES SORTED BY E.LAST_NAME &RDB& FOR D IN DEGREES WITH D.EMPLOYEE_ID = E.EMPLOYEE_ID &RDB& GET &RDB& first_name = E.FIRST_NAME; &RDB& last_name = E.LAST_NAME; &RDB& degree = D.DEGREE; &RDB& degree_field = D.DEGREE_FIELD &RDB& END_GET DISPLAY "Name is: ", first_name, SPACE, last_name "Degree is: ", degree "Degree field is: ", degree_field &RDB& END_FOR * Use the NOT ANY clause to create a stream of all the records in the * EMPLOYEES relation that do not have an associated record in * the DEGREES relation. * Then use the FIRST clause to step through this stream. The FOR * statement previously created for the EMPLOYEES relation is still * active; this will cause the FIRST clause to step through the stream * created by the NOT ANY clause. &RDB& FOR FIRST 1 D IN DEGREES WITH NOT ANY D1 IN DEGREES &RDB& WITH D1.EMPLOYEE_ID = E.EMPLOYEE_ID &RDB& GET &RDB& first_name = E.FIRST_NAME; &RDB& last_name = E.LAST_NAME; &RDB& END_GET * Print the names from the EMPLOYEES relation who do not have * an associated record stored in DEGREES. DISPLAY first_name, " ", last_name, " Does not have this information stored in the database" &RDB& END_FOR &RDB& END_FOR &RDB& COMMIT DISPLAY "Press any key to continue " NO ADVANCING ACCEPT continue_key. Seniority. ********************************************************* * This procedure lists employees in order of seniority. * ********************************************************* DISPLAY SPACE LINE 1 COLUMN 1 ERASE TO END OF SCREEN DISPLAY "List of employees by seniority" LINE 1 COLUMN 20 DISPLAY "" LINE 2 COLUMN 1 &RDB& START_TRANSACTION READ_ONLY * Create a stream of record by crossing the EMPLOYEES relation * with a stream of records from the SALARY_HISTORY relation that * have the value for the SALARY_END field flagged as missing. * The assumption is that if the SALARY_END field is missing, * this record is the current record. Sort the records in ascending * order of the salary start date. &RDB& FOR SH IN SALARY_HISTORY CROSS E IN EMPLOYEES OVER EMPLOYEE_ID &RDB& SORTED BY SH.SALARY_START &RDB& GET &RDB& first_name = E.FIRST_NAME; &RDB& last_name = E.LAST_NAME; &RDB& salary_start = SH.SALARY_START &RDB& END_GET * Display the retrieved records; use SYS$ASCTIM to convert * the date, which is stored in binary format. DISPLAY first_name, " ", last_name NO ADVANCING DISPLAY " started work on: " NO ADVANCING CALL "SYS$ASCTIM" USING BY REFERENCE size_of_ascii_date BY DESCRIPTOR ascii_date BY REFERENCE salary_start DISPLAY ascii_date(1:11) &RDB& END_FOR &RDB& COMMIT DISPLAY "Press any key to continue " NO ADVANCING ACCEPT continue_key. Pair. ********************************************************************* * This procedure demonstrates the use of the declared START_STREAM * * statement. The output of this procedure is merely a random * * matching of each CANDIDATES record with an EMPLOYEES record. * ********************************************************************* * Declare two streams: one for the CANDIDATES relation and the other * for the EMPLOYEES relation. &RDB& DECLARE_STREAM cands USING CA IN CANDIDATES SORTED BY CA.LAST_NAME &RDB& DECLARE_STREAM emps USING EM IN EMPLOYEES SORTED BY EM.FIRST_NAME &RDB& START_TRANSACTION READ_ONLY * Open both streams and set a flag for the end-of-stream condition * to false. PERFORM Open_candidates PERFORM Open_employees INITIALIZE end_of_emps_flag, end_of_cands_flag * Fetch a record from the CANDIDATES and EMPLOYEES relations. PERFORM Read_a_candidate PERFORM Read_an_employee * Print the employees and candidates names until the end of stream * condition is met for the stream of CANDIDATES records. PERFORM UNTIL end_of_cands DISPLAY last_name, first_name, ' ', candidate_last_name, candidate_first_name PERFORM Read_a_candidate IF NOT end_of_emps THEN PERFORM Read_an_employee END-IF END-PERFORM * Close both streams. PERFORM Close_employees PERFORM Close_candidates &RDB& COMMIT. DISPLAY "Press any key to continue " NO ADVANCING ACCEPT continue_key. * Set of procedures to control streams. Note that the statements * do not appear in the order that they will be executed. This is * a functionality that declared streams have and undeclared streams * do not have. Open_candidates. * Open the CANDIDATES stream. &RDB& START_STREAM cands. Open_employees. * Open the EMPLOYEES stream. &RDB& START_STREAM emps. Read_a_candidate. * Fetch a CANDIDATES record. &RDB& FETCH cands &RDB& AT END MOVE 'Y' TO end_of_cands_flag &RDB& END_FETCH IF NOT end_of_cands THEN &RDB& GET &RDB& candidate_last_name = CA.LAST_NAME; &RDB& candidate_first_name= CA.FIRST_NAME; &RDB& candidate_status = CA.CANDIDATE_STATUS &RDB& END_GET. Read_an_employee. * Fetch an EMPLOYEES record. &RDB& FETCH emps &RDB& AT END MOVE 'Y' TO end_of_emps_flag &RDB& END_FETCH IF NOT end_of_emps THEN &RDB& GET &RDB& last_name = EM.LAST_NAME; &RDB& first_name = EM.FIRST_NAME; &RDB& employee_id = EM.EMPLOYEE_ID &RDB& END_GET. Close_employees. * Close the EMPLOYEES stream. &RDB& END_STREAM emps. Close_candidates. * Close the CANDIDATES stream. &RDB& END_STREAM cands. Stats. ********************************************************************** * This procedure displays the total number of records stored in the * * EMPLOYEES relation. * ********************************************************************** DISPLAY SPACE LINE 1 COLUMN 1 ERASE TO END OF SCREEN DISPLAY "Statistics" LINE 1 COLUMN 20 DISPLAY "" LINE 2 COLUMN 1 &RDB& START_TRANSACTION READ_ONLY DISPLAY "The number of employees in the Corporation are: " NO ADVANCING * Use the GET statement with a statistical function to calculate the * total number of records in the EMPLOYEES relation. &RDB& GET &RDB& number_of_employees = COUNT OF E IN EMPLOYEES &RDB& END_GET * Display the value. DISPLAY number_of_employees &RDB& COMMIT DISPLAY SPACE DISPLAY "Press any key to continue " NO ADVANCING ACCEPT continue_key. Store_cand. **************************************************************************** * This procedure stores a record in the CANDIDATES relation. It shows how * * to store a value in a field of data type VARYING STRING. * **************************************************************************** DISPLAY SPACE LINE 1 COLUMN 1 ERASE TO END OF SCREEN DISPLAY "Store Candidates" LINE 1 COLUMN 20 DISPLAY "" LINE 2 COLUMN 1 * Prompt the user for data to store in the CANDIDATES relation. DISPLAY "Please enter the first name of the candidate or type exit: " NO ACCEPT candidate_first_name PROTECTED REVERSED PERFORM UNTIL candidate_first_name = "EXIT" OR "exit" INITIALIZE confirm_flag PERFORM until confirm DISPLAY "Please enter the candidates middle initial: " NO ADVANCING ACCEPT candidate_middle_initial PROTECTED REVERSED DISPLAY "Please enter the last name of the candidate: "NO ADVANCING ACCEPT candidate_last_name PROTECTED REVERSED DISPLAY "Please enter candidate status information: " NO ADVANCING ACCEPT candidate_status DISPLAY "Have you entered the candidate - " information correctly(Y/N): " NO ADVANCING ACCEPT confirm_flag PROTECTED REVERSED END-PERFORM &RDB& START_TRANSACTION READ_WRITE RESERVING CANDIDATES FOR SHARED WRITE MOVE 'Y' TO success_flag * Store the values specified by the user in the CANDIDATES relation. * Trap for errors and inform the user of the success or failure of * the STORE operation. &RDB& STORE C IN CANDIDATES USING &RDB& ON ERROR MOVE "N" TO success_flag CALL "Error_handler" USING RDB$STATUS, retry_count, success_flag, lock_error_flag &RDB& END_ERROR &RDB& C.LAST_NAME = candidate_last_name; &RDB& C.FIRST_NAME = candidate_first_name; &RDB& C.MIDDLE_INITIAL = candidate_middle_initial; &RDB& C.CANDIDATE_STATUS = candidate_status &RDB& END_STORE IF successful THEN DISPLAY "Update operation succeeded" &RDB& COMMIT ELSE DISPLAY "Update operation failed" &RDB& ROLLBACK END-IF DISPLAY "Please enter the first name of the candidate or type exit: " NO ACCEPT candidate_first_name PROTECTED REVERSED END-PERFORM. Display_cand. ************************************************************************* * This procedure displays a record from the CANDIDATES relation. * * It shows how to display a field stored as data type VARYING STRING. * * Refer to the WORKING STORAGE section to how variables are declared. * ************************************************************************* DISPLAY SPACE LINE 1 COLUMN 1 ERASE TO END OF SCREEN DISPLAY "Display Candidates" LINE 1 COLUMN 20 DISPLAY "" LINE 2 COLUMN 1 * Prompt user for information needed to identify a record in the * CANDIDATES relation. DISPLAY "Please enter the first name of the candidate or type exit: " NO ACCEPT candidate_first_name PROTECTED REVERSED PERFORM UNTIL candidate_first_name = "EXIT" OR "exit" INITIALIZE confirm_flag PERFORM until confirm OR (candidate_first_name = "EXIT" OR "exit") DISPLAY "Please enter the candidates middle initial: " NO ADVANCING ACCEPT candidate_middle_initial PROTECTED REVERSED DISPLAY "Please enter the last name of the candidate: " NO ADVANCING ACCEPT candidate_last_name PROTECTED REVERSED DISPLAY "Have you entered the candidate - " information correctly (Y/N): " NO ADVANCING ACCEPT confirm_flag PROTECTED REVERSED IF NOT confirm THEN DISPLAY "Please enter the first name of the candidate or - " type exit: " NO ADVANCING ACCEPT candidate_first_name PROTECTED REVERSED END-IF END-PERFORM IF NOT (candidate_first_name = "EXIT" OR "exit") THEN &RDB& START_TRANSACTION READ_ONLY INITIALIZE found_candidate_flag &RDB& FOR C IN CANDIDATES WITH C.FIRST_NAME = candidate_first_name &RDB& AND C.MIDDLE_INITIAL = candidate_middle_initial &RDB& AND C.LAST_NAME = candidate_last_name * Retrieve and display the VARYING STRING field if a record exists * for the specified candidate. If no record exists for this person, * inform the user. &RDB& GET candidate_status = C.CANDIDATE_STATUS END_GET MOVE "Y" TO found_candidate_flag DISPLAY candidate_first_name SPACE candidate_middle_initial SPACE candidate_last_name "has the following status:" DISPLAY SPACE DISPLAY candidate_status &RDB& END_FOR &RDB& COMMIT IF NOT found_candidate THEN DISPLAY "No such candidate on file" END-IF DISPLAY "Please enter the first name of the candidate - " or type exit: " NO ADVANCING ACCEPT candidate_first_name PROTECTED REVERSED END-IF END-PERFORM. Find_missing. ******************************************************************** * This procedure prints the employee ID of all employees in the * * DEGREES relation who do not have a value stored in the DEGREES * * field. * ******************************************************************** DISPLAY SPACE LINE 1 COLUMN 1 ERASE TO END OF SCREEN DISPLAY "Employee IDs of employees in DEGREES with an unknown area of - " study" LINE 1 COLUMN 5 DISPLAY "" LINE 2 COLUMN 1 &RDB& START_TRANSACTION READ_ONLY * Use the MISSING value expression to find all records in the * DEGREES relation that have the DEGREE_FIELD flagged as missing. * Print the employee id of all employees in the DEGREES relation * who do not have a value stored in the DEGREES field. &RDB& FOR D IN DEGREES WITH D.DEGREE_FIELD MISSING &RDB& GET &RDB& employee_id = D.EMPLOYEE_ID &RDB& END_GET DISPLAY employee_id &RDB& END_FOR &RDB& COMMIT DISPLAY "Press any key to continue " NO ADVANCING ACCEPT continue_key. Rdbdollarmissing. **************************************************************** * This procedure demonstrates how to use the RDB$MISSING value * * expression to mark a field as missing. * **************************************************************** DISPLAY SPACE LINE 1 COLUMN 1 ERASE TO END OF SCREEN DISPLAY "Store a record in degrees" LINE 1 COLUMN 5 DISPLAY "" LINE 2 COLUMN 1 * Prompt the user for values to store in the COLLEGES relation. DISPLAY "Please enter the EMPLOYEE ID number or type exit: " NO ADVANCING ACCEPT demployee_id PROTECTED REVERSED PERFORM UNTIL demployee_id = "EXIT" OR "exit" INITIALIZE confirm_flag PERFORM until confirm DISPLAY "Please enter the college code: " NO ADVANCING ACCEPT dcollege_code PROTECTED REVERSED DISPLAY "Please enter the year the degree was granted: " - NO ADVANCING ACCEPT year_given PROTECTED REVERSED DISPLAY "Please enter the degree: " NO ADVANCING ACCEPT degree PROTECTED REVERSED * Direct user to enter a question mark if he or she is uncertain of the * DEGREE_FIELD for the record being stored. DISPLAY "Please enter the field in which the degree was granted" DISPLAY "If unknown, enter '?': " NO ADVANCING ACCEPT degree_field PROTECTED REVERSED DISPLAY "Have you entered the degree information correctly? - "(Y/N): " NO ADVANCING ACCEPT confirm_flag PROTECTED REVERSED END-PERFORM * If the user entered a question mark for the DEGREE_FIELD, then * retrieve the missing value that is defined for the DEGREE_FIELD field. &RDB& START_TRANSACTION READ_WRITE RESERVING DEGREES FOR SHARED WRITE IF degree_field = '?' THEN &RDB& GET &RDB& degree_field = RDB$MISSING(DEGREES.DEGREE_FIELD) &RDB& END_GET END-IF * Store the user specified values in the DEGREES relation. If he * entered a question mark for DEGREE_FIELD, the missing value * defined for DEGREE_FIELD will be stored, otherwise the value * specified by the user will be stored. &RDB& STORE D IN DEGREES USING &RDB& D.EMPLOYEE_ID = demployee_id; &RDB& D.COLLEGE_CODE = dcollege_code; &RDB& D.YEAR_GIVEN = year_given; &RDB& D.DEGREE = degree; &RDB& D.DEGREE_FIELD = degree_field &RDB& END_STORE &RDB& COMMIT DISPLAY "Please enter the EMPLOYEE ID number or type exit: " - NO ADVANCING ACCEPT demployee_id PROTECTED REVERSED END-PERFORM. Mod_resume. ************************************************************* * This procedure demonstrates how to modify a field of data * * type SEGMENTED_STRING. * ************************************************************* DISPLAY SPACE LINE 1 COLUMN 1 ERASE TO END OF SCREEN DISPLAY "Modify a resume" LINE 1 COLUMN 5 DISPLAY "" LINE 2 COLUMN 1 DISPLAY "Please enter the ID of the employee or type exit: " NO ACCEPT employee_id PROTECTED REVERSED PERFORM UNTIL employee_id = "EXIT" OR "exit" DISPLAY "To modify a resume, you must supply a new " DISPLAY " resume to replace the old resume" DISPLAY SPACE * Prompt the user for the file name of the resume that will replace * the old resume. DISPLAY "Please enter file name of new resume: " NO ADVANCING ACCEPT file-name PROTECTED REVERSED &RDB& START_TRANSACTION READ_WRITE RESERVING RESUMES FOR SHARED WRITE * Create a new segmented string that will hold the value * of the new resume. &RDB& CREATE_SEGMENTED_STRING resume_handle OPEN INPUT resume_file INITIALIZE eof_flag MOVE SPACES TO resume_line READ resume_file AT END MOVE "Y" TO eof_flag END-READ PERFORM UNTIL end_of_file &RDB& STORE R IN resume_handle USING R.RDB$VALUE = resume_line END_STORE MOVE SPACES TO resume_line READ resume_file AT END MOVE "Y" TO eof_flag END-READ END-PERFORM CLOSE resume_file &RDB& END_SEGMENTED_STRING resume_handle * Modify the old resume by supplying the segmented string handle * from the CREATE_SEGMENTED_STRING statement as the object * of the segmented string assignment statement. &RDB& FOR R IN RESUMES WITH R.EMPLOYEE_ID = employee_id &RDB& MODIFY R USING &RDB& R.RESUME = resume_handle &RDB& END_MODIFY &RDB& END_FOR &RDB& COMMIT DISPLAY "Please enter the ID of the employee or type exit: " NO ACCEPT employee_id PROTECTED REVERSED END-PERFORM. Display_resume. *********************************************************** * This procedure demonstrates how to retrieve a field of * * data type SEGMENTED STRING. * *********************************************************** DISPLAY SPACE LINE 1 COLUMN 1 ERASE TO END OF SCREEN DISPLAY "Display Resume " LINE 1 COLUMN 5 DISPLAY "" LINE 2 COLUMN 1 * Prompt use to enter the ID of the employee * resume that he or she wants to view. If user * enters 'exit' then exit the procedure. DISPLAY "Please enter the ID of the employee whose resume " DISPLAY "you want to display or type exit: " NO ADVANCING ACCEPT employee_id PROTECTED REVERSED PERFORM UNTIL employee_id = "EXIT" OR "exit" &RDB& START_TRANSACTION READ_ONLY INITIALIZE found_employee_flag * Start an outer FOR loop to retrieve the employees record(s) * with the specified id. &RDB& FOR R IN RESUMES WITH R.EMPLOYEE_ID = employee_id MOVE 'Y' TO found_employee_flag * Start an inner FOR loop to retrieve the segments * of the segmented string that comprise the employee's * resume. &RDB& FOR RR IN R.RESUME &RDB& GET &RDB& resume_segment = RR.RDB$VALUE; &RDB& segment_length = RR.RDB$LENGTH &RDB& END_GET * Display each segment as it is retrieved from the database. DISPLAY resume_segment(1:segment_length) &RDB& END_FOR &RDB& END_FOR &RDB& COMMIT * If a record with the specified ID was not found then inform * the user. IF NOT found_employee THEN DISPLAY 'Employee: ', employee_id, ' has no resume on file' END-IF DISPLAY SPACE DISPLAY "Please enter the ID of the employee whose resume " DISPLAY "you want to display or type exit: " NO ADVANCING ACCEPT employee_id PROTECTED REVERSED END-PERFORM. Ddl_stmnt. ******************************************************************* * This procedure demonstrates how to perform data definition task * * from an RDBPRE COBOL program. You must use the Callable RDO * * interface, RDB$INTERPRET, to perform data definition tasks in * * preprocessed programs. * ******************************************************************* DISPLAY SPACE LINE 1 COLUMN 1 ERASE TO END OF SCREEN DISPLAY "Execute a DDL statement " LINE 1 COLUMN 5 DISPLAY "" LINE 2 COLUMN 1 * Invoke the database to make it known to Callable RDO. CALL "RDB$INTERPRET" USING BY DESCRIPTOR 'DATABASE !VAL = FILENAME "MF_PERSONNEL" ', BY DESCRIPTOR dbhandle GIVING return_status IF return_status IS FAILURE THEN CALL "Callable_error_handler" USING return_status, retry_count, lock_error_flag MOVE 'N' TO success_flag END-IF * Perform procedure to prompt user for input. PERFORM Enter_ddl_statement PERFORM UNTIL no_more_ddl_statements INITIALIZE confirm_flag PERFORM UNTIL confirm OR no_more_ddl_statements DISPLAY "Did you enter the definition correctly (Y/N): " - NO ADVANCING ACCEPT confirm_flag PROTECTED REVERSED IF NOT confirm THEN PERFORM Enter_ddl_statement END-IF END-PERFORM INITIALIZE transaction_started_flag, retry_count PERFORM UNTIL transaction_started OR retry_count > 5 MOVE 'Y' TO transaction_started_flag * Start a READ_WRITE transaction. CALL "RDB$INTERPRET" USING BY DESCRIPTOR "START_TRANSACTION READ_WRITE" GIVING return_status IF return_status IS FAILURE THEN CALL "Callable_error_handler" USING return_status, retry_count, lock_error_flag MOVE 'N' TO success_flag, transaction_started_flag END-IF END-PERFORM IF transaction_started THEN INITIALIZE success_flag, retry_count, lock_error_flag PERFORM WITH TEST AFTER UNTIL successful OR (lock_error AND retry_count > 5) OR (NOT lock_error) MOVE 'Y' TO success_flag * Pass the data definition statement specified by the user to * RDB$INTERPRET. CALL "RDB$INTERPRET" USING BY DESCRIPTOR ddl_statement GIVING return_status IF return_status IS FAILURE THEN CALL "Callable_error_handler" USING return_status, retry_count, lock_error_flag MOVE 'N' TO success_flag END-IF END-PERFORM * Inform the user of the success or failure of the data definition * task. IF successful THEN DISPLAY "Transaction successful" CALL "RDB$INTERPRET" USING BY DESCRIPTOR "COMMIT" GIVING return_status ELSE DISPLAY "Trasaction failed" CALL "RDB$INTERPRET" USING BY DESCRIPTOR "ROLLBACK" GIVING return_status END-IF END-IF PERFORM Enter_ddl_statement END-PERFORM CALL "RDB$INTERPRET" USING BY DESCRIPTOR "FINISH" GIVING return_status. Enter_ddl_statement. * Prompt user for input. Ordinarily, it would not be likely that * you would ask a user to define an index for the database. * This example serves only to show you how this type of task can * be done within a COBOL environment. DISPLAY 'Please enter the data definition statement to define' DISPLAY 'or delete a temporary index, or type "exit"' DISPLAY SPACE DISPLAY 'For example, to define an index for EMPLOYEES based' DISPLAY 'on EMPLOYEE_ID, you might enter: ' DISPLAY SPACE DISPLAY 'define index emp_employee_id for employees duplicates are allowed.' REVERSED DISPLAY 'employee_id. end emp_employee_id index.' REVERSED DISPLAY SPACE DISPLAY 'To delete this index, you might enter: ' DISPLAY SPACE DISPLAY 'delete index emp_employee_id.' REVERSED DISPLAY SPACE ACCEPT ddl_statement REVERSED. Callable. ********************************************************************** * This procedure demonstrates how to embed Callable RDO statements * * that perform data manipulation tasks in an RDBPRE COBOL program. * * Note that you should always use RDBPRE COBOL DML to perform data * * manipulation tasks in COBOL, unless special circumstances require * * that you use Callable RDO. Callable RDO uses more resources and * * is slower than using RDBPRE. * ********************************************************************** DISPLAY SPACE LINE 1 COLUMN 1 ERASE TO END OF SCREEN DISPLAY "Retrieve college information using callable RDO" LINE 1 COLUMN 5 DISPLAY "" LINE 3 COLUMN 1 INITIALIZE success_flag * Invoke the database in Callable RDO. The INVOKE DATABASE * statement issued at the beginning of the program (using RDBPRE) * is unknown to Callable RDO. If an error occurs during the invoke, * call an error handler. CALL "RDB$INTERPRET" USING BY DESCRIPTOR 'DATABASE !VAL = FILENAME "MF_PERSONNEL" ', BY DESCRIPTOR dbhandle GIVING return_status IF return_status IS FAILURE THEN CALL "Callable_error_handler" USING return_status, retry_count, lock_error_flag MOVE 'N' TO success_flag END-IF * Prompt user for the college code of the COLLEGES record he or she * wants to view. DISPLAY "Please enter college code of the college or type Exit " NO ACCEPT college_code PROTECTED REVERSED PERFORM UNTIL college_code = "EXIT" OR "exit" INITIALIZE transaction_started_flag, retry_count PERFORM UNTIL transaction_started OR retry_count > 5 MOVE 'Y' TO transaction_started_flag * Pass the START_TRANSACTION statement to RDB$INTERPRET. CALL "RDB$INTERPRET" USING BY DESCRIPTOR "START_TRANSACTION READ_WRITE RESERVING - " COLLEGES FOR EXCLUSIVE WRITE NOWAIT" GIVING return_status IF return_status IS FAILURE THEN CALL "Callable_error_handler" USING return_status, retry_count, lock_error_flag MOVE 'N' TO success_flag, transaction_started_flag END-IF END-PERFORM IF transaction_started THEN MOVE 'Y' TO success_flag * Start a stream of COLLEGES records. CALL "RDB$INTERPRET" USING BY DESCRIPTOR "START_STREAM COLL_INFO USING C IN - "COLLEGES WITH C.COLLEGE_CODE = !VAL" BY DESCRIPTOR college_code GIVING return_status IF return_status IS FAILURE THEN CALL "Callable_error_handler" USING return_status, retry_count, lock_error_flag MOVE 'N' TO success_flag END-IF IF successful THEN MOVE 'Y' TO success_flag CALL "RDB$INTERPRET" USING BY DESCRIPTOR "FETCH coll_info" GIVING return_status IF return_status IS FAILURE THEN CALL "Callable_error_handler" USING return_status, retry_count, lock_error_flag MOVE 'N' TO success_flag END-IF IF successful * Retrieve the value of a COLLEGES record. THEN CALL "RDB$INTERPRET" USING BY DESCRIPTOR "GET !VAL = c.college_name; - " !VAL = c.city - "END_GET" BY DESCRIPTOR college_name, BY DESCRIPTOR college_city GIVING return_status * Display the record. DISPLAY college_name DISPLAY college_city END-IF CALL "RDB$INTERPRET" USING BY DESCRIPTOR "END_STREAM coll_info" GIVING return_status END-IF END-IF * Commit the transaction if 'success' equals true, * otherwise, roll back the transaction. IF successful AND transaction_started THEN CALL "RDB$INTERPRET" USING BY DESCRIPTOR "COMMIT" GIVING return_status ELSE CALL "RDB$INTERPRET" USING BY DESCRIPTOR "ROLLBACK" GIVING return_status END-IF DISPLAY "Please enter college code of the college or type Exit " NO ADVANCING ACCEPT college_code PROTECTED REVERSED END-PERFORM CALL "RDB$INTERPRET" USING BY DESCRIPTOR "FINISH" GIVING return_status. Store_res. ************************************************************* * This procedure demonstrates how to store a record with a * * field of data type SEGMENTED STRING. * ************************************************************* DISPLAY SPACE LINE 1 COLUMN 1 ERASE TO END OF SCREEN DISPLAY "Modify a resume" LINE 1 COLUMN 5 DISPLAY "" LINE 2 COLUMN 1 * Prompt user for the employee ID of the employee that * he or she wants to store. DISPLAY "Please enter the ID of the new employee or type exit: " NO ACCEPT employee_id PROTECTED REVERSED PERFORM UNTIL employee_id = "EXIT" OR "exit" INITIALIZE confirm-flag PERFORM until confirm * Prompt user for the file name of the resume to be stored. DISPLAY "Please enter file name of new resume: " NO ADVANCING ACCEPT file-name PROTECTED REVERSED DISPLAY "Have you entered all data correctly? (Y,N) " NO ADVANCING ACCEPT confirm_flag PROTECTED REVERSED END-PERFORM &RDB& START_TRANSACTION READ_WRITE RESERVING RESUMES FOR SHARED WRITE * Create a segmented string to hold the values from the specified file. &RDB& CREATE_SEGMENTED_STRING resume_handle OPEN INPUT resume_file INITIALIZE eof_flag MOVE SPACES TO resume_line READ resume_file AT END MOVE "Y" TO eof_flag END-READ PERFORM UNTIL end_of_file &RDB& STORE R IN resume_handle USING R.RDB$VALUE = resume_line END_STORE MOVE SPACES TO resume_line READ resume_file AT END MOVE "Y" TO eof_flag END-READ END-PERFORM CLOSE resume_file &RDB& END_SEGMENTED_STRING resume_handle * Store the new record by supplying the segmented string handle from * the CREATE_SEGMENTED_STRING statement as the object of the segmented * string assignment statement. &RDB& STORE R IN RESUMES USING - R.EMPLOYEE_ID = employee_id; - R.RESUME = resume_handle - END_STORE &RDB& COMMIT DISPLAY "Please enter the ID of the new Employee or type exit: " NO ACCEPT employee_id PROTECTED REVERSED END-PERFORM. END PROGRAM Sample. IDENTIFICATION DIVISION. PROGRAM-ID. Error_handler. *********************************************************** * This program handles run-time errors trapped by the * * ON ERROR clause in preprocessed RDBPRE COBOL programs. * *********************************************************** ENVIRONMENT DIVISION. INPUT-OUTPUT SECTION. FILE-CONTROL. SELECT error_file ASSIGN 'error_log'. DATA DIVISION. FILE SECTION. FD error_file. 01 error_record PIC X(132). * Declare variables, including symbolic error codes and system * service library routines. WORKING-STORAGE SECTION. 01 LIB$SIGNAL PIC S9(9) COMP VALUE IS EXTERNAL LIB$SIGNAL. 01 exception_codes. 05 RDB$_LOCK_CONFLICT PIC S9(9) COMP VALUE IS EXTERNAL RDB$_LOCK_CONFLICT. 05 RDB$_DEADLOCK PIC S9(9) COMP VALUE IS EXTERNAL RDB$_DEADLOCK. 05 RDB$_NO_DUP PIC S9(9) COMP VALUE IS EXTERNAL RDB$_NO_DUP. 05 RDB$_NOT_VALID PIC S9(9) COMP VALUE IS EXTERNAL RDB$_NOT_VALID. 05 RDB$_INTEG_FAIL PIC S9(9) COMP VALUE IS EXTERNAL RDB$_INTEG_FAIL. 05 RDB$_STREAM_EOF PIC S9(9) COMP VALUE IS EXTERNAL RDB$_STREAM_EOF. 05 RDB$_NO_RECORD PIC S9(9) COMP VALUE IS EXTERNAL RDB$_NO_RECORD. 01 return_status PIC S9(9) COMP. 01 RDB$MESSAGE_VECTOR EXTERNAL. 03 Rdb$LU_NUM_ARGUMENTS PIC S9(9) COMP. 03 Rdb$LU_STATUS PIC S9(9) COMP. 03 Rdb$ALU_ARGUMENTS OCCURS 18 TIMES. 05 Rdb$LU_ARGUMENTS PIC S9(9) COMP. 01 seconds_to_wait COMP-1 VALUE 5. 01 getmsgvars. 05 msg_id PIC 9(9) COMP. 05 msg_len PIC 9(9) COMP. 05 msg_txt PIC X(132). 05 mask PIC 9(9) COMP VALUE 15. 05 out_array PIC X(4). LINKAGE SECTION. 01 RDB$STATUS PIC S9(9) COMP. 01 retry-count PIC S9(4) COMP. 01 success_flag PIC X. 01 lock_error_flag PIC X. PROCEDURE DIVISION USING RDB$STATUS, retry_count, success_flag, lock_error_flag. Check_error. * Use LIB$MATCH_COND to determine which of a series of * errors might have occurred. CALL "Lib$match_cond" USING RDB$STATUS, RDB$_LOCK_CONFLICT RDB$_DEADLOCK, RDB$_NO_DUP, RDB$_NOT_VALID, RDB$_INTEG_FAIL RDB$_NO_RECORD GIVING return_status * The COBOL EVALUATE statement directs program to appropriate * statements to execute depending on the error that * was trapped. EVALUATE return_status WHEN 0 PERFORM Unexpected_error WHEN 1 THRU 2 PERFORM Lock_problem WHEN 3 PERFORM Duplicate_not_allowed WHEN 4 PERFORM Invalid_data WHEN 5 PERFORM Integrity_failure WHEN 6 PERFORM Record_deleted END-EVALUATE DISPLAY SPACE EXIT PROGRAM. Unexpected_error. DISPLAY "Unexpected error - terminating program" OPEN EXTEND error_file CALL "SYS$GETMSG" USING BY VALUE rdb$status BY REFERENCE msg_len BY DESCRIPTOR msg_txt BY VALUE mask BY REFERENCE out_array GIVING return_status MOVE msg_txt(1:msg_len) TO error_record DISPLAY error_record WRITE error_record CLOSE error_file CALL "LIB$CALLG" USING BY REFERENCE Rdb$MESSAGE_VECTOR BY VALUE LIB$SIGNAL. Lock_problem. * Invoked on lock conflict or deadlock. * Retry 5 times before rolling back. MOVE 'Y' TO lock_error_flag IF (retry-count > 5) THEN DISPLAY "Another user is accessing data you attempted to access" MOVE "N" TO success_flag ELSE CALL "LIB$WAIT" USING seconds_to_wait ADD 1 TO retry-count END-IF. Duplicate_not_allowed. DISPLAY "You attempted to insert a record with a value already on file" DISPLAY SPACES * Display the error message to see what index violated duplicate clause. CALL "SYS$PUTMSG" USING BY REFERENCE Rdb$MESSAGE_VECTOR DISPLAY "Please choose a new value and try again". Invalid_data. DISPLAY "In the data you entered, you specified an invalid value" DISPLAY SPACES. * Display the error message to see what data was invalid. CALL "SYS$PUTMSG" USING BY REFERENCE Rdb$MESSAGE_VECTOR DISPLAY "Please correct the error and try again". Integrity_failure. DISPLAY "In the data you entered, you violated a constraint" DISPLAY SPACES. * Display the error message to see what constraint was violated. CALL "SYS$PUTMSG" USING BY REFERENCE Rdb$MESSAGE_VECTOR DISPLAY "Please correct the error and try again". Record_deleted. DISPLAY "Record entered has been deleted". END PROGRAM Error_handler.