* Copyright © Oracle Corporation 1995.  All Rights Reserved. 
IDENTIFICATION DIVISION.
PROGRAM-ID. Callable_error_handler.

********************************************************************
*  This is an Error handling routine for Callable RDO statements.  *
********************************************************************

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).
WORKING-STORAGE SECTION.
01   RDB$SIGNAL    PIC S9(9) COMP VALUE IS EXTERNAL RDB$SIGNAL.

01    exception_codes.
    05    RDB$_STREAM_EOF        PIC S9(9) COMP
          VALUE IS EXTERNAL RDB$_STREAM_EOF.

    05    RDB$_DEADLOCK        PIC S9(9) COMP
          VALUE IS EXTERNAL RDB$_DEADLOCK.

    05    RDB$_LOCK_CONFLICT        PIC S9(9) COMP
          VALUE IS EXTERNAL RDB$_LOCK_CONFLICT.

    05    RDB$_INTEG_FAIL        PIC S9(9) COMP
          VALUE IS EXTERNAL RDB$_INTEG_FAIL.

    05    RDB$_NO_DUP        PIC S9(9) COMP
          VALUE IS EXTERNAL RDB$_NO_DUP.

    05    rdo$_indnotdef         PIC S9(9) COMP
          VALUE IS EXTERNAL rdo$_indnotdef.

    05    RDB$_NOT_VALID        PIC S9(9) COMP
          VALUE IS EXTERNAL RDB$_NOT_VALID.


01 return_status                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 error_status                 PIC S9(9) COMP.
01 retry-count			PIC S9(4) COMP.
01 lock_error_flag              PIC X.

PROCEDURE DIVISION USING error_status, retry_count, lock_error_flag.

Check_error.
    CALL "Lib$MATCH_COND"  USING     error_status
                                     RDB$_DEADLOCK,
                                     RDB$_LOCK_CONFLICT
                                     RDB$_NO_DUP,
                                     RDB$_NOT_VALID,
                                     RDB$_INTEG_FAIL
                                     RDB$_STREAM_EOF
                           GIVING    return_status

    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 End_of_stream
    END-EVALUATE.
    
    EXIT PROGRAM.

Unexpected_error.
    DISPLAY "Unexpected error - terminating program" 
    OPEN EXTEND error_file
    CALL "SYS$GETMSG" USING BY VALUE error_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 error_status
                           BY VALUE RDB$SIGNAL.


Lock_problem.
* Invoked on lock conflict or deadlock.
* Retry 5 times before rolling back.

    MOVE 'Y' TO lock_error_flag
    ADD 1 TO retry-count
    IF   (retry-count > 5)
    THEN DISPLAY "Sorry, resources are not available, please retry later"
    ELSE DISPLAY "Others are using data that you want to access"
         DISPLAY "Trying to access data again..."
         CALL "LIB$WAIT" USING seconds_to_wait
    END-IF.


Duplicate_not_allowed.
    DISPLAY "You attempted to insert a record with a value already on file"
    DISPLAY SPACES
    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 "Please correct the error and try again".

Integrity_failure.
    DISPLAY "In the data you entered, you violated a constraint"
    DISPLAY SPACES.
    DISPLAY "Please correct the error and try again".

End_of_stream.
    DISPLAY "There are no colleges that match that code".

END PROGRAM Callable_error_handler.