C     
C     $Header: fdemo1.for 7001200.1 92/11/10 00:09:07 twang Generic<base> $ 
C     
C  Copyright (c) 1991 by Oracle Corporation 
C    NAME
C      fdemo1.for - Fortran demo program #1
C    MODIFIED   (MM/DD/YY)
C     rkooi2     11/05/92 -  Portability mods 
C     sjain      03/16/92 -  Creation 

      PROGRAM FDEMO1

*---------------------------------------------------------------
*  FDEMO1 is a demonstration program that adds new employee
*  rows to the personnel data base.  Checking
*  is done to insure the integrity of the data base.
*  The employee numbers are automatically selected using
*  the current maximum employee number as the start.
*  If any employee number is a duplicate, it is skipped.
*  The program queries the user for data as follows:
*
*    Enter employee name  :
*    Enter employee job   :
*    Enter employee salary:
*    Enter employee dept  :
*
*  If just <cr> is entered for the employee name,
*  the program terminates.
*
*  If the row is successfully inserted, the following
*  is printed:
*
*  ENAME added to DNAME department as employee N.
*
*  The maximum lengths of the 'ename', 'job', and 'dname'
*  columns are determined by an ODESCR call.
*
*  Note: VAX FORTRAN, by default, passes all CHARACTER variables
*  (variables declared as CHARACTER*N) by descriptor.  Since OCI
*  address parameters must be passed by reference, all character
*  string variables in the following program are passed using the
*  VAX FORTRAN extension: %REF().
*  To compile this program on systems that do not pass character
*  variables by descriptor, remove the references to %REF().
*---------------------------------------------------------------

      IMPLICIT INTEGER (A-Z)

      INTEGER*2         LDA(32)
      INTEGER*2         CURS(32,2)
      INTEGER*2         HDA(128)
      CHARACTER*20      UID, PSW

*  CHARACTER string vars to hold the SQL statements

      CHARACTER*60      SMAX
      CHARACTER*60      SEMP
      CHARACTER*100     INS
      CHARACTER*60      SEL

      INTEGER*4         SMAXL, SEMPL, INSL, SELL

*  Program vars to be bound to SQL placeholders and
*  select-list fields .

      INTEGER*4         EMPNO, DEPTNO, SAL
      CHARACTER*10      ENAME
      CHARACTER*10      JOB
      CHARACTER*14      DNAME

*  Actual lengths of columns .

      INTEGER*4         ENAMES, JOBS, DNAMES

*  Character strings for SQL placeholders.

      CHARACTER*6       ENON
      CHARACTER*6       ENAN
      CHARACTER*4       JOBN
      CHARACTER*4       SALN
      CHARACTER*7       DEPTN

*  Lengths of character strings for SQL placeholders.

      INTEGER*4         ENONL, ENANL, JOBNL, SALNL, DEPTNL

*  Parameters for OPARSE.

      INTEGER*4         NODEFP, V7FLAG

*  Parameters for ODESCR.

      INTEGER*2     DTYPE, PREC, SCALE, NULLOK
      INTEGER*4     DSIZE, CNAMEL
      CHARACTER*80  CNAME

*---------------------------------------------------------------
*  Initialize variables.
*---------------------------------------------------------------

      SMAX = 'SELECT NVL(MAX(EMPNO),0) FROM EMP'
      SMAXL = LEN_TRIM(SMAX)

      SEMP = 'SELECT ENAME,JOB FROM EMP'
      SEMPL=  LEN_TRIM(SEMP)

      INS = 'INSERT INTO EMP(EMPNO,ENAME,JOB,SAL,
     + DEPTNO) VALUES (:EMPNO,:ENAME,:JOB,:SAL,:DEPTNO)'
      INSL = LEN_TRIM(INS)

      SEL = 'SELECT DNAME FROM DEPT WHERE DEPTNO = :1'
      SELL = LEN_TRIM(SEL)

      NODEFP = 0
      V7FLAG = 2
      ENAMEL = 10
      JOBL   = 10
      EMPNOL = 4
      DEPTL  = 4
      SALL   = 4

      ENON = ':EMPNO'
      ENAN = ':ENAME'
      JOBN = ':JOB'
      SALN = ':SAL'
      DEPTN = ':DEPTNO'

      ENONL = 6
      ENANL = 6
      JOBNL = 4
      SALNL = 4
      DEPTNL = 7

*---------------------------------------------------------------
*  Connect to ORACLE.
*---------------------------------------------------------------

      UID = 'SCOTT'
      PSW = 'TIGER'

      CALL ORLON(LDA(1), HDA, %REF(UID), LEN_TRIM(UID),
     +           %REF(PSW), LEN_TRIM(PSW), 0)
      IF (LDA(7).NE.0) THEN
          CALL ERRRPT(LDA(1), LDA(1))
          GO TO 900
      END IF

      WRITE (*, '(1X, A, A20)') 'Logged on to ORACLE as user ',
     +      UID

*---------------------------------------------------------------
*  Open two cursors for the personnel data base.
*---------------------------------------------------------------

      CALL OOPEN(CURS(1,1), LDA)
      IF (CURS(1,1).NE.0) THEN
        CALL ERRRPT(LDA(1), CURS(1,1))
        GO TO 700
      END IF

      CALL OOPEN(CURS(1,2),LDA(1))
      IF (CURS(1,2).NE.0) THEN
        CALL ERRRPT(LDA(1), CURS(1,2))
        GO TO 700
      END IF

*---------------------------------------------------------------
*  Turn off auto-commit.  Note: the default is off,
*  so this could be omitted.
*---------------------------------------------------------------

      CALL OCOF(LDA(1))
      IF (LDA(1).NE.0) THEN
        CALL ERRRPT(LDA(1), LDA(1))
        GO TO 700
      END IF

*---------------------------------------------------------------
*  Retrieve the current maximum employee number.
*----------------------------------------------------------------

*  Parse the SQL statement.  Note that %REF is a VAXISM.

      CALL OPARSE(CURS(1,1), %REF(SMAX), SMAXL, NODEFP, V7FLAG)
      IF (CURS(1,1).NE.0) THEN
        CALL ERRRPT(LDA(1), CURS(1,1))
        GO TO 700
      END IF

*  Define a buffer to receive the MAX(EMPNO) from ORACLE.

      CALL ODEFIN(CURS(1,1), 1, EMPNO, 4, 3)
      IF (CURS(1,1).NE.0) THEN
        CALL ERRRPT(LDA(1), CURS(1,1))
        GO TO 700
      END IF


*  Execute the SQL statement.

      CALL OEXEC(CURS(1,1))
      IF (CURS(1,1).NE.0) THEN
        CALL ERRRPT(LDA(1), CURS(1,1))
        GO TO 700
      END IF

*  Fetch the data from ORACLE into the defined buffer.

      CALL OFETCH(CURS(1,1))
      IF (CURS(1,1).EQ.0) GO TO 50
      IF (CURS(7,1).NE.1403) THEN
        CALL ERRRPT(LDA(1), CURS(1,1))
        GO TO 700
      END IF

*  A cursor return code of 1403 means that no row
*  satisfied the query, so generate the first empno.

      EMPNO=10
50    CONTINUE

*---------------------------------------------------------------
*  Determine the max length of the employee name and job title.
*  Parse the SQL statement - it will not be executed.
*  Describe the two fields specified in the SQL statement.
*----------------------------------------------------------------

      CALL OPARSE(CURS(1,1), %REF(SEMP), SEMPL, NODEFP, V7FLAG)
      IF (CURS(1,1).NE.0) THEN
        CALL ERRRPT(LDA(1), CURS(1,1))
        GO TO 700
      END IF

      CNAMEL = 80
      CALL ODESCR(CURS(1,1), 1, ENAMES, DTYPE, %REF(CNAME),
     +            CNAMEL, DSIZE, PREC, SCALE, NULLOK)
      IF (CURS(1,1).NE.0) THEN
        CALL ERRRPT(LDA(1), CURS(1,1))
        GO TO 700
      END IF

      IF (ENAMES .GT. ENAMEL) THEN
        WRITE (*, '(1X, A, I2, A, I2)') 'ENAME too large (',
     +   ENAMES, ' for buffer (', ENAMEL, ').'
        GO TO 700
      END IF

      CNAMEL = 80
      CALL ODESCR(CURS(1,1), 2, JOBS, DTYPE, %REF(CNAME),
     +            CNAMEL, DSIZE, PREC, SCALE, NULLOK)
      IF (CURS(1,1).NE.0) THEN
        CALL ERRRPT(LDA(1), CURS(1,1))
        GO TO 700
      END IF

      IF (JOBS .GT. JOBL) THEN
        WRITE (*, '(1X, A, I2, A, I2)') 'JOB too large (',
     +   JOBS, ' for buffer (', JOBL, ').'
        GO TO 700
      END IF

*--------------------------------------------------------------
*  Parse the insert and select statements.
*--------------------------------------------------------------

      CALL OPARSE(CURS(1,1), %REF(INS), INSL, NODEFP, V7FLAG)
      IF (CURS(1,1).NE.0) THEN
        CALL ERRRPT(LDA(1), CURS(1,1))
        GO TO 700
      END IF

      CALL OPARSE(CURS(1,2), %REF(SEL), SELL, NODEFP, V7FLAG)
      IF (CURS(1,2).NE.0) THEN
        CALL ERRRPT(LDA(1), CURS(1,2))
        GO TO 700
      END IF

*--------------------------------------------------------------
*  Bind all placeholders.
*--------------------------------------------------------------

      CALL OBNDRV(CURS(1,1), %REF(ENON), LEN(ENON), EMPNO, EMPNOL, 3)
      IF (CURS(1,1).NE.0) THEN
        CALL ERRRPT(LDA(1), CURS(1,1))
        GO TO 700
      END IF

      CALL OBNDRV(CURS(1,1), %REF(ENAN), ENANL, %REF(ENAME), ENAMEL,1)
      IF (CURS(1,1).NE.0) THEN
        CALL ERRRPT(LDA(1), CURS(1,1))
        GO TO 700
      END IF

      CALL OBNDRV(CURS(1,1), %REF(JOBN), JOBNL, %REF(JOB), JOBL, 1)
      IF (CURS(1,1).NE.0) THEN
        CALL ERRRPT(LDA(1), CURS(1,1))
        GO TO 700
      END IF

      CALL OBNDRV(CURS(1,1), %REF(SALN), SALNL ,SAL, SALL, 3)
      IF (CURS(1,1).NE.0) THEN
        CALL ERRRPT(LDA(1), CURS(1,1))
        GO TO 700
      END IF

      CALL OBNDRV(CURS(1,1), %REF(DEPTN), DEPTNL, DEPTNO, DEPTL, 3)
      IF (CURS(1,1).NE.0) THEN
        CALL ERRRPT(LDA(1), CURS(1,1))
        GO TO 700
      END IF

*--------------------------------------------------------------
*  Bind the DEPTNO variable.
*--------------------------------------------------------------

      CALL OBNDRN(CURS(1,2), 1, DEPTNO, DEPTL, 3)
      IF (CURS(1,2).NE.0) THEN
        CALL ERRRPT(LDA(1), CURS(1,2))
        GO TO 700
      END IF

*--------------------------------------------------------------
*  Describe the DNAME column - get the name and length.
*--------------------------------------------------------------

      DNAMEL = 14
      CALL ODESCR(CURS(1,1), 1, DNAMES, DTYPE, %REF(DNAME),
     +            DNAMEL, DSIZE, PREC, SCALE, NULLOK)
      IF (CURS(1,2).NE.0) THEN
        CALL ERRRPT(LDA(1), CURS(1,2))
        GO TO 700
      END IF

      IF (DNAMES .GT. DNAMEL) THEN
        WRITE (*, '(1X, A)') 'DNAME too large for buffer.'
        GO TO 700
      END IF

*--------------------------------------------------------------
*  Define the buffer to receive DNAME.
*--------------------------------------------------------------

      CALL ODEFIN(CURS(1,2), 1, %REF(DNAME), DNAMEL, 1)
      IF (CURS(1,2).NE.0) THEN
        CALL ERRRPT(LDA(1), CURS(1,2))
        GO TO 700
      END IF

*--------------------------------------------------------------
*  Read the user's input.  Statement 100
*  starts the main program loop.
*--------------------------------------------------------------

100   WRITE (*, '(''$'', A)')
     +  'Enter employee name (CR to QUIT) : '
      READ (*, '(A)'), ENAME
      IF (LEN_TRIM(ENAME) .EQ. 0) GO TO 700
      WRITE (*, '(''$'', A)'), 'Enter employee job   : '
      READ (*, '(A)'), JOB
      WRITE (*, '(''$'', A)') 'Enter employee salary: '
      READ (*, '(I6)'), SAL
300   WRITE (*, '(''$'', A)') 'Enter employee dept  : '
      READ (*, '(I6)'), DEPTNO

*--------------------------------------------------------------
*  Check for a valid department number by
*  executing the SELECT statement.
*--------------------------------------------------------------

      CALL OEXEC(CURS(1,2))
      IF (CURS(1,2).NE.0) THEN
        CALL ERRRPT(LDA(1), CURS(1,2))
        GO TO 700
      END IF

*--------------------------------------------------------------
*  Fetch the rows - DEPTNO is a primary key, so a max of
*  one row will be fetched.
*  If the return code is 1403 no such department exists.
*--------------------------------------------------------------

      CALL OFETCH(CURS(1,2))
      IF (CURS(1,2).EQ.0) GO TO 500
      IF (CURS(7,2).NE.1403) THEN
        CALL ERRRPT(LDA(1), CURS(1,2))
        GO TO 700
      END IF

      WRITE (*, '(1X, A)') 'No such department number'
      GO TO 300

*--------------------------------------------------------------
*  Increment EMPNO by 10.
*  Execute the insert statement.
*--------------------------------------------------------------

500   EMPNO = EMPNO + 10
      CALL OEXEC(CURS(1,1))
      IF (CURS(1,1).EQ.0) GO TO 600

*--------------------------------------------------------------
*  If the call returns code 1 (duplicate value in index),
*  generate the next possible employee number.
*--------------------------------------------------------------

      IF (CURS(7,1).NE.1) THEN
        CALL ERRRPT(LDA(1), CURS(1,1))
        GO TO 700
      END IF

      EMPNO=EMPNO+10
      GO TO 500

600   WRITE (*, 610) ENAME, DNAME, EMPNO
610   FORMAT(/, 1X, A10, ' added to the ', A14,
     +    ' department as employee# ', I4, /)

*--------------------------------------------------------------
*  The row has been added - commit this transaction.
*--------------------------------------------------------------

      CALL OCOM(LDA(1))
      IF (LDA(1).NE.0) THEN
        CALL ERRRPT(LDA(1), LDA(1))
        GO TO 700
      END IF

      GO TO 100

*--------------------------------------------------------------
*  Either a fatal error has occurred or the user typed
*  <CR> for the employee name.
*  Close the cursors, disconnect, and end the program.
*--------------------------------------------------------------

700   CONTINUE

      CALL OCLOSE(CURS(1,1))
      IF (CURS(1,1).NE.0) CALL ERRRPT(LDA(1), CURS(1,1))
      CALL OCLOSE(CURS(1,2))
      IF (CURS(1,2).NE.0) CALL ERRRPT(LDA(1), CURS(1,2))

      CALL OLOGOF(LDA(1))
      IF (LDA(1).NE.0) CALL ERRRPT(LDA(1), LDA(1))
900   STOP
      END


*--------------------------------------------------------------
*  ERRRPT prints the cursor number, the error code, and the
*  OCI function code.
*
*  CURS is a cursor.
*  N is the cursor number.
*--------------------------------------------------------------

      SUBROUTINE ERRRPT(LDA, CURS)
      INTEGER*2 CURS(32), LDA(32)

      CHARACTER*160 ERRMSG

      IF (CURS(6) .GT. 0) THEN
        WRITE (*, '(1X, A, I3)') 'ORACLE error processing OCI
     + function ', CURS(6)
      END IF

      CALL OERHMS(LDA(1), CURS(7), %REF(ERRMSG), 160)
      WRITE (*, '(1X, A)') ERRMSG

      RETURN
      END


      INTEGER FUNCTION LEN_TRIM(STRING)
      CHARACTER*(*) STRING

      INTEGER NEXT

      DO 10 NEXT = LEN(STRING), 1, -1
        IF (STRING(NEXT : NEXT) .NE. ' ') THEN
          LEN_TRIM = NEXT
          RETURN
        ENDIF
10    CONTINUE

      LEN_TRIM = 0

      RETURN
      END

