-- Copyright © Oracle Corporation 1995. All Rights Reserved. -- ABSTRACT: -- -- This program demonstrates the use of a cursor to fetch and update -- rows in the database using DEC Ada and the module language feature -- in the SQL interface to Oracle Rdb. The name of the file containing -- the module language procedures is SQL_TERMINATE_ADA.SQLMOD. -- -- In this sample, the operator will be prompted for the employee id and -- termination date of an employee until the operator asks to exit. -- The employee id will be used to check for the employee by opening a -- cursor and fetching the employee row. If the employee is found in the -- database, three tables will be updated with the employee's status and -- termination date. The transaction will be committed and the next -- operator request will be prompted for. -- with CONDITION_HANDLING; with STARLET; with SYSTEM; with TEXT_IO; use TEXT_IO; procedure SQL_TERMINATE is -- The following declarations are for SQL call error handling SQL_RETURN_STATUS : integer; SQL_SUCCESS : constant integer := 0; ID_NOT_FOUND : constant integer := 100; DEADLOCK : constant integer := -913; LOCK_CONFLICT : constant integer := -1003; ID_NOT_FOUND_ERROR, LOCK_CONFLICT_ERROR, UNEXPECTED_ERROR : exception; -- String subtype declarations subtype STRING1 is string(1..1); subtype STRING5 is string(1..5); -- Variables for main program use UPDATE_CODE : constant character := '1'; EXIT_CODE : constant character := '8'; RELEASE_SCREEN : character; EMPLOYEE_ID : string5; JOB_END : starlet.date_time_type; -- GETMSG variables used with the customized message file SQL_PERSMSG -- -- SQL_PERSMSG message symbols are passed via the GETMSG call. This program -- illustrates a variety of ways to handle errors, and the customized message -- file is used only for one error condition. Ordinarily, if your program were -- using a customized message file, you would use it for many more error -- conditions and would make more than one symbol declaration. MSGID : condition_handling.cond_value_type := 0; MSGLEN : system.unsigned_word; BUFADR : string(1..132); FLAGS : system.unsigned_longword := 15; PERS_IDNOTFND : constant condition_handling.cond_value_type := SYSTEM.IMPORT_VALUE("PERS_IDNOTFND"); -- Declare SQL$GET_ERROR_TEXT; the procedure must be declared and -- pragmas to specify the external interface must also be provided procedure SQL_GET_ERROR_TEXT(ERROR_TEXT : out string; ERROR_TEXT_LEN : out short_integer); pragma INTERFACE(SQL,SQL_GET_ERROR_TEXT); pragma IMPORT_PROCEDURE(internal => SQL_GET_ERROR_TEXT, external => "SQL$GET_ERROR_TEXT", parameter_types => (string,short_integer), mechanism => (descriptor,reference)); -- SQL$GET_ERROR_TEXT variables. GET_ERROR_BUFFER : string(1..256); GET_ERROR_LENGTH : short_integer; -- Declare variable for system service call return status VMS_RETURN_STATUS : condition_handling.cond_value_type; -- SQL module language procedure declarations -- including the INTERFACE pragmas procedure SET_TRANSACTION(SQLCODE : out integer); procedure OPEN_CURSOR(SQLCODE : out integer; P_EMPLOYEE_ID : in string5); procedure FETCH_EMPLOYEES(SQLCODE : out integer; P_EMPLOYEE_ID : out string5; P_STATUS_CODE : out string1); procedure UPDATE_EMPLOYEES(SQLCODE : out integer); procedure UPDATE_JOBHIST(SQLCODE : out integer; P_EMPLOYEE_ID : in string5; P_JOB_END : in starlet.date_time_type); procedure UPDATE_SALHIST(SQLCODE : out integer; P_EMPLOYEE_ID : in string5; P_JOB_END : in starlet.date_time_type); procedure COMMIT_TRANSACTION(SQLCODE : out integer); procedure ROLLBACK_TRANSACTION(SQLCODE: out integer); pragma INTERFACE(SQL, SET_TRANSACTION); pragma INTERFACE(SQL, OPEN_CURSOR); pragma INTERFACE(SQL, FETCH_EMPLOYEES); pragma INTERFACE(SQL, UPDATE_EMPLOYEES); pragma INTERFACE(SQL, UPDATE_JOBHIST); pragma INTERFACE(SQL, UPDATE_SALHIST); pragma INTERFACE(SQL, COMMIT_TRANSACTION); pragma INTERFACE(SQL, ROLLBACK_TRANSACTION); -------------------------------------------------------------------------------- -- Functions and procedures used by the main program -------------------------------------------------------------------------------- function MAIN_OPTION_INPUT return character is VALID_CODE : boolean := false; OPTION_ENTRY : character; begin while not valid_code loop new_line(24); put_line("INACTIVE STATUS UPDATE PROGRAM"); new_line; put_line("Please enter a selection number."); put_line("1 : to update an employee's status to inactive"); put_line("8 : to exit this program"); new_line; put("Enter option: "); get(option_entry); new_line; case option_entry is when update_code => valid_code := true; when exit_code => valid_code := true; when others => put("Invalid option. "); put("Type 'C' and press to continue. "); get(release_screen); end case; end loop; return option_entry; end MAIN_OPTION_INPUT; procedure GET_EMPLOYEE_INFO is -- The following declarations are for VMS system service call error handling IVTIME_ERROR : exception; pragma IMPORT_EXCEPTION(ivtime_error, "SS$_IVTIME"); -- Variables for use in constructing the date-time string for conversion END_DATE : string(1..11); END_DATE_TIME : string(1..23); begin new_line(24); put("Please enter the employee id number "); put_line("of the employee who is now inactive"); new_line; put("Employee ID: "); get(employee_id); new_line; put_line("Please enter the job termination date."); put_line("Use format dd-MMM-yyyy (for example 21-OCT-1986)."); new_line; put("Date: "); get(end_date); new_line; end_date_time := end_date & " 00:00:00.00"; -- Convert the start date to DATE datatype format using BINTIM in STARLET -- Use the function SUCCESS in package condition_handling to check on the -- return from BINTIM starlet.bintim(vms_return_status,end_date_time,job_end); if not condition_handling.success(vms_return_status) then raise ivtime_error; end if; exception when ivtime_error => put_line("Invalid date format. No update occurred."); raise; end GET_EMPLOYEE_INFO; function EMPLOYEE_EXISTS return boolean is EMPLOYEE_FOUND : boolean := true; EMP_ID : string5; STATUS_CODE : string1; begin -- Call to SQL to START a TRANSACTION; check status on return set_transaction(sql_return_status); case sql_return_status is when sql_success => null; when lock_conflict | deadlock => raise lock_conflict_error; when others => raise unexpected_error; end case; -- Call to SQL to OPEN a CURSOR; check status on return open_cursor(sql_return_status,employee_id); case sql_return_status is when sql_success => null; when lock_conflict | deadlock => raise lock_conflict_error; when others => raise unexpected_error; end case; -- Call to SQL to FETCH a row from the opened cursor fetch_employees(sql_return_status,emp_id,status_code); case sql_return_status is when sql_success => null; when id_not_found => raise id_not_found_error; when others => raise unexpected_error; end case; -- Success to this point means that a row was returned by the FETCH. This -- program assumes that it is the employee to be updated and checks no further. -- Simply return with the employee_found flag true. -- Seperate objects were used for employee_id for the input parameter to this -- function and the call to fetch_employees so that a test could be performed -- if desired return employee_found; exception when lock_conflict_error => rollback_transaction(sql_return_status); put_line("A lock condition has occurred."); put("Type 'C' and press to continue. "); get(release_screen); employee_found := false; return employee_found; when unexpected_error => sql_get_error_text(get_error_buffer,get_error_length); rollback_transaction(sql_return_status); put_line("This condition was not expected."); put_line(get_error_buffer(1..integer(get_error_length))); put("Type 'C' and press to continue. "); get(release_screen); employee_found := false; return employee_found; when id_not_found_error => rollback_transaction(sql_return_status); msgid := pers_idnotfnd; starlet.getmsg(vms_return_status,msgid,msglen,bufadr,flags); if not condition_handling.success(vms_return_status) then condition_handling.stop(vms_return_status); end if; put_line(bufadr(1..integer(msglen))); put("Type 'C' and press to continue. "); get(release_screen); employee_found := false; return employee_found; end EMPLOYEE_EXISTS; procedure UPDATE_DATABASE is begin -- Call to SQL to UPDATE the EMPLOYEES table update_employees(sql_return_status); case sql_return_status is when sql_success => null; when lock_conflict | deadlock => raise lock_conflict_error; when others => raise unexpected_error; end case; -- Call to SQL to UPDATE the JOB_HISTORY table update_jobhist(sql_return_status,employee_id,job_end); case sql_return_status is -- Include id_not_found error as a non-error in this program; -- it signifies that there are no rows with JOB_END = null, -- probably as a result of duplicate update when sql_success | id_not_found => null; when lock_conflict | deadlock => raise lock_conflict_error; when others => raise unexpected_error; end case; -- Call to SQL to UPDATE the SALARY_HISTORY table update_salhist(sql_return_status,employee_id,job_end); case sql_return_status is -- Include id_not_found error as a non-error in this program; -- it signifies that there are no rows with SALARY_END = null, -- probably as a result of duplicate update when sql_success | id_not_found => null; when lock_conflict | deadlock => raise lock_conflict_error; when others => raise unexpected_error; end case; -- Call to SQL to COMMIT the TRANSACTION commit_transaction(sql_return_status); case sql_return_status is when sql_success => null; when lock_conflict | deadlock => raise lock_conflict_error; when others => raise unexpected_error; end case; exception when lock_conflict_error => rollback_transaction(sql_return_status); put_line("A lock condition has occurred."); put("Type 'C' and press to continue. "); get(release_screen); when unexpected_error => sql_get_error_text(get_error_buffer,get_error_length); rollback_transaction(sql_return_status); put_line("This condition was not expected."); put_line(get_error_buffer(1..integer(get_error_length))); put("Type 'C' and press to continue. "); get(release_screen); end UPDATE_DATABASE; ------------------------------------------------------------------------------- -- Main program ------------------------------------------------------------------------------- begin -- The main program will loop until the operator requests to exit. -- The main option dialog returns an option code that controls the loop. -- If an update is requested, the employee id and termination date for the -- employee is requested. The database is checked for the employee id and -- is the employee's status and termination date are updated if it is found. loop if main_option_input = exit_code then exit; end if; get_employee_info; if employee_exists then update_database; end if; end loop; -- Exceptions that are raised in subprograms will be reraised to cause the -- program to exit, where appropriate. The exceptions can only be handled -- anonymously outside of the scope in which they are raised, hence the use -- of only the others clause. exception when others => null; -- will simply cause an exit to occur end SQL_TERMINATE;