home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 1996 February / PCWK0296.iso / po7_win / db / rdbms71 / fdemo2.for < prev    next >
Text File  |  1994-08-07  |  10KB  |  374 lines
  1. C     
  2. C     $Header: fdemo2.for 7000901.1 92/03/21 18:05:55 twang Generic<base> $ 
  3. C     
  4. C  Copyright (c) 1991 by Oracle Corporation 
  5. C    NAME
  6. C      fdemo2.for - Fortran demo program # 2
  7. C    MODIFIED   (MM/DD/YY)
  8. C     sjain      03/16/92 -  Creation 
  9. *  FDEMO2.FOR
  10. *  A dynamic SQL OCI example program.  Processes
  11. *  SQL statements entered interactively by the user.
  12.  
  13.       PROGRAM FDEMO2
  14.       IMPLICIT INTEGER*4 (A-Z)
  15.  
  16. *  Data structures
  17. *  Logon and cursor areas
  18.       INTEGER*2      CDA(32), LDA(32), HDA(128)
  19.  
  20. *  Bind values
  21.       CHARACTER*20   BVARV(8)
  22.       INTEGER        NBV
  23.  
  24. *  Output values
  25.       CHARACTER*10   DVARC(8)
  26.       INTEGER        DVARI(8)
  27.       REAL*4         DVARF(8)
  28.       INTEGER*2      DBTYPE(8), RLEN(8), RCODE(8)
  29.       INTEGER*2      INDP(8)
  30.       INTEGER        NOV
  31.  
  32. *  Column names for SELECT
  33.       CHARACTER*10   COLNAM(8)
  34.  
  35. *  SQL statement buffer and logon info
  36.       CHARACTER*80   SQLSTM, UID, PWD
  37.       INTEGER        UIDL, PWDL, SQLL
  38.  
  39.       UID = 'SCOTT'
  40.       PWD = 'TIGER'
  41.       UIDL = LEN_TRIM(UID)
  42.       PWDL = LEN_TRIM(PWD)
  43.  
  44. *  Connect to ORACLE.
  45.       CALL ORLON(LDA, HDA, %REF(UID), UIDL, %REF(PWD), PWDL, 0)
  46.       IF (LDA(7) .NE. 0) THEN
  47.         CALL ERRRPT(LDA, CDA)
  48.         GO TO 999
  49.       ENDIF
  50.       WRITE (*, '(1X, A, A)') 'Connected to ORACLE as user ', UID
  51.  
  52. *  Open a cursor.
  53.       CALL OOPEN(CDA, LDA, %REF(UID), 0, -1, %REF(PWD), 0)
  54.       IF (LDA(7) .NE. 0) THEN
  55.         CALL ERRRPT(LDA, CDA)
  56.         GO TO 900
  57.       ENDIF
  58.  
  59.       WRITE (*, '(1X, A)') 'Enter SQL statements (132 char max)'
  60.  
  61. *  Beginning of the main program loop.
  62. *  Get and process SQL statements.
  63. 100   WRITE (*, '(/''$'', A)') '> '
  64.       READ '(A)', SQLSTM
  65.  
  66.       SQLL = LEN_TRIM(SQLSTM)
  67.       IF (SQLL .EQ. 0) GO TO 100
  68.  
  69.       I = INDEX(SQLSTM, ';')
  70.       IF (I .GT. 0) THEN
  71.         SQLL = I - 1
  72.       ENDIF
  73.  
  74.       IF ((SQLSTM(1:4) .EQ. 'exit') .OR.
  75.      +    (SQLSTM(1:4) .EQ. 'EXIT')) GO TO 900
  76.  
  77. *  Parse the statement.
  78.       CALL OPARSE(CDA, %REF(SQLSTM), SQLL, 0, 2)
  79.       IF (CDA(7) .NE. 0) THEN
  80.         CALL ERRRPT(LDA, CDA)
  81.         GO TO 100
  82.       ENDIF
  83.  
  84. *  If there are bind values, obtain them from user.
  85.       CALL GETBNV(LDA, CDA, SQLSTM, BVARV, NBV)
  86.       IF (NBV .LT. 0) GO TO 100
  87.  
  88. *  Define the output variables.  If the statement is not a
  89. *  query, NOV returns as 0.  If there were errors defining
  90. *  the output variables, NOV returns as -1.
  91.       CALL DEFINE(LDA, CDA, COLNAM, DBTYPE, DVARC, DVARI,
  92.      +            DVARF, INDP, RLEN, RCODE, NOV)
  93.       IF (NOV .LT. 0) GO TO 100
  94.  
  95. *  Execute the statement.
  96.       CALL OEXN(CDA, 1)
  97.       IF (CDA(7) .NE. 0) THEN
  98.         CALL ERRRPT(LDA, CDA)
  99.         GO TO 100
  100.       ENDIF
  101.  
  102. *  Fetch rows and display output if the statement was a query.
  103.       CALL FETCHN(LDA, CDA, COLNAM, NOV, DBTYPE, DVARC,
  104.      +            DVARI, DVARF, INDP, RV)
  105.       IF (RV .LT. 0) GO TO 100
  106.  
  107. *  Loop back to statement 100 to process
  108. *  another SQL statement.
  109.       GO TO  100
  110.  
  111. *  End of main program loop.  Here on exit or fatal error.
  112. 900   CALL OCLOSE(CDA)
  113.       CALL OLOGOF(LDA)
  114.  
  115. *  End of program.  Come here if connect fails.
  116. 999   END
  117.  
  118.  
  119. *  Begin subprograms.
  120.  
  121.       SUBROUTINE GETBNV(LDA, CDA, STMT, BVARV, N)
  122.       IMPLICIT INTEGER*4 (A-Z)
  123.       INTEGER*2     LDA(32), CDA(32)
  124.       CHARACTER*(*) STMT
  125.       CHARACTER*(*) BVARV(8)
  126.  
  127. *     Arrays for bind variable info.
  128.       INTEGER       BVARI(8), BVARL(8)
  129.  
  130. *  Scan the SQL statement for placeholders (:ph).
  131. *  Note that a placeholder must be terminated with
  132. *  a space, a comma, or a close parentheses.
  133. *  Two arrays are maintained: an array of starting
  134. *  indices in the string (BVARI), and an array of
  135. *  corresponding lengths (BVARL).
  136.       POS = 1
  137.       DO 300 K = 1, 8            ! maximum of 8 per statement
  138.         I = INDEX(STMT(POS:), ':')
  139.         IF (I .EQ. 0) GO TO 400
  140.         POS = I + POS - 1
  141.         BVARI(K) = POS
  142.         DO 100 J = POS, LEN(STMT)
  143.           IF (STMT(J:J) .EQ. ' '
  144.      +       .OR. STMT(J:J) .EQ. ','
  145.      +       .OR. STMT(J:J) .EQ. ')') THEN
  146.             BVARL(K) = J - POS
  147.             GO TO 200
  148.           ENDIF
  149. 100     CONTINUE
  150.  
  151. 200     POS = POS + 1               ! index past the ':'
  152. 300   CONTINUE
  153.  
  154. 400   N = K - 1                     ! N is the number of BVs
  155.  
  156.       DO 500 K = 1, N
  157.         CALL OBNDRV(CDA, %REF(STMT(BVARI(K) :)), BVARL(K),
  158.      +              %REF(BVARV(K)), 20, 1)
  159.         IF (CDA(7) .NE. 0) THEN
  160.           CALL ERRRPT(LDA, CDA)
  161.           N = -1
  162.           RETURN
  163.         ENDIF
  164.         WRITE (*, '(''$'', A, A, A)') 'Enter value for ',
  165.      +        STMT(BVARI(K)+1:BVARI(K)+BVARL(K)-1), '  --> '
  166.         READ '(A)', BVARV(K)
  167. 500   CONTINUE
  168.  
  169.       RETURN
  170.       END
  171.  
  172.  
  173. *  Define output variables for queries.
  174. *  Returns the number of select-list items (N)
  175. *  and the names of the select-list items (COLNAM).
  176. *  A maximum of 8 select-list items is permitted.
  177. *  (Note that this program does not check if there
  178. *   are more, but a production-quality program
  179. *   must do this.)
  180.  
  181.       SUBROUTINE DEFINE(LDA, CDA, COLNAM, DBTYPE, DVARC,
  182.      +                  DVARI, DVARF, INDP, RLEN, RCODE, RV)
  183.       IMPLICIT INTEGER*4 (A-Z)
  184.       INTEGER*2       LDA(32), CDA(32), DBTYPE(8)
  185.       INTEGER*2       RLEN(8), RCODE(8), INDP(8)
  186.       CHARACTER*(*)   DVARC(8), COLNAM(8)
  187.       INTEGER         DVARI(8), RV
  188.       REAL*4          DVARF(8)
  189.  
  190.       INTEGER         DBSIZE(8), COLNML(8), DSIZE(8)
  191.       INTEGER*2       PREC(8), SCALE(8), NOK(8)
  192.  
  193. *  If not a query (SQL function code .ne. 4), return.
  194.       IF (CDA(2) .NE. 4) THEN
  195.         RV = 0
  196.         RETURN
  197.       ENDIF
  198.  
  199. *  Describe the select-list (up to 8 items max),
  200. *  and define an output variable for each item, with the
  201. *  external (hence, FORTRAN) type depending on the
  202. *  internal ORACLE type, and its attributes.
  203.  
  204.       DO 100 N = 1, 8
  205.         COLNML(N) = 10  ! COL length must be set on the call
  206.         CALL ODESCR(CDA, N, DBSIZE(N), DBTYPE(N),
  207.      +       %REF(COLNAM(N)), COLNML(N), DSIZE(N),
  208.      +       PREC(N), SCALE(N), NOK(N))
  209.  
  210. *  If the return code from ODESCR is 1007, then you have
  211. *  reached the end of the select list.
  212.         IF (CDA(7) .EQ. 1007) THEN
  213.           GO TO 200
  214. *  Otherwise, if the return code is non-zero, an
  215. *  error occurred. Exit the subroutine, signalling
  216. *  an error.
  217.         ELSE IF (CDA(7) .NE. 0) THEN
  218.           CALL ERRRPT(LDA, CDA)
  219.           RV = -1                ! Error on return
  220.           RETURN
  221.         ENDIF
  222.  
  223. *  Check the datatype of the described item.  If it's a
  224. *  NUMBER, check if the SCALE is 0.  If so, define the
  225. *  output variable as INTEGER (3). If it's NUMBER with SCALE != 0,
  226. *  define the output variable as REAL (4).  Otherwise,
  227. *  it's assumed to be a DATE, LONG, CHAR, or VARCHAR2,
  228. *  so define the output as 1 (VARCHAR2).
  229.  
  230.         IF (DBTYPE(N) .EQ. 2) THEN
  231.           IF (SCALE(N) .EQ. 0) THEN
  232.             DBTYPE(N) = 3
  233.           ELSE
  234.             DBTYPE(N) = 4
  235.           ENDIF
  236.         ELSE
  237.           DBTYPE(N) = 1
  238.         ENDIF
  239.  
  240. *  Define the output variable.  Do not define RLEN if
  241. *  the external datatype is 1.
  242.         IF (DBTYPE(N) .EQ. 3) THEN
  243.           CALL ODEFIN(CDA, N, DVARI(N), 4, 3, 0, INDP(N),
  244.      +                FMT, 0, 0, RLEN(N), RCODE(N))
  245.         ELSE IF (DBTYPE(N) .EQ. 4) THEN
  246.           CALL ODEFIN(CDA, N, DVARF(N), 4, 4, 0, INDP(N),
  247.      +                FMT, 0, 0, RLEN(N), RCODE(N))
  248.         ELSE
  249.           CALL ODEFIN(CDA, N, %REF(DVARC(N)), 10, 1, 0, INDP(N),
  250.      +                FMT, 0, 0, %VAL(-1), RCODE(N))
  251.         ENDIF
  252.         IF (CDA(7) .NE. 0) THEN
  253.           CALL ERRRPT(LDA, CDA)
  254.           RV = -1
  255.           RETURN
  256.         ENDIF
  257. 100   CONTINUE
  258.  
  259. 200   RV = N - 1             ! Decrement to get correct count
  260.  
  261.       RETURN
  262.       END
  263.  
  264.  
  265. *  FETCHN uses OFETCH to fetch the rows that satisfy
  266. *  the query, and displays the output.  The data is
  267. *  fetched 1 row at a time.
  268.  
  269.       SUBROUTINE FETCHN(LDA, CDA, NAMES, NOV, DBTYPE, DVARC,
  270.      +                  DVARI, DVARF, INDP, RV)
  271.       IMPLICIT INTEGER*4 (A-Z)
  272.       INTEGER*2     LDA(32), CDA(32), DBTYPE(8), INDP(8)
  273.       CHARACTER*(*) NAMES(8), DVARC(8)
  274.       INTEGER       DVARI(8), NOV, RV
  275.       REAL*4        DVARF(8)
  276.  
  277.       IF (CDA(2) .NE. 4) THEN         ! not a query
  278.         RV = 0
  279.         RETURN
  280.       ENDIF
  281.  
  282.       DO 50 COL = 1, NOV
  283.         IF (DBTYPE(COL) .EQ. 1) THEN
  284.           WRITE (*, 900) NAMES(COL), ' '
  285. 900       FORMAT ('+', A10, A1, $)
  286.         ELSE
  287.           WRITE (*, 902) NAMES(COL), ' '
  288. 902       FORMAT ('+', A8, A1, $)
  289.         ENDIF
  290. 50    CONTINUE
  291.  
  292.       WRITE (*, '(1X, A, /)') '------------------------------
  293.      +-----------------------------------------------'
  294.  
  295.       DO 200 NROWS = 1, 10000
  296.         CALL OFETCH(CDA)
  297.         IF (CDA(7) .EQ. 1403) GO TO 300
  298.         IF (CDA(7) .NE. 0 .AND. CDA(7) .NE. 1406) THEN
  299.           CALL ERRRPT(LDA, CDA)
  300.           RV = -1
  301.           RETURN
  302.         ENDIF
  303.         DO 100 COL = 1, NOV
  304.           IF (INDP(COL) .LT. 0 .AND. DBTYPE(COL) .NE. 1) THEN
  305.             WRITE (*, 903), '         '
  306. 903         FORMAT ('+', A9, $)
  307.           ELSE IF (INDP(COL) .LT. 0 .AND. DBTYPE(COL) .EQ. 1) THEN
  308.             WRITE (*, 905), '           '
  309. 905         FORMAT ('+', A11, $)
  310.           ELSE    
  311.             IF (DBTYPE(COL) .EQ. 3) THEN
  312.               WRITE (*, 904) DVARI(COL), '   '
  313. 904           FORMAT ('+', I6, A3, $)
  314.             ELSE IF (DBTYPE(COL) .EQ. 4) THEN
  315.               WRITE (*, 906) DVARF(COL), ' '
  316. 906           FORMAT ('+', F8.2, A1, $)
  317.             ELSE
  318.               WRITE (*, 908) DVARC(COL), ' '
  319. 908           FORMAT ('+', A10, A1, $)
  320.             ENDIF
  321.           ENDIF
  322. 100     CONTINUE
  323.         WRITE (*, '(1X)')
  324. 200   CONTINUE
  325.  
  326. 300   NROWS = NROWS - 1
  327.       WRITE (*, '(/, 1X, I3, A)') NROWS, ' rows returned'
  328.  
  329.       RETURN
  330.       END
  331.  
  332.  
  333.  
  334.       SUBROUTINE ERRRPT(LDA, CDA)
  335.       INTEGER*2 LDA(32), CDA(32)
  336.       
  337.       CHARACTER*132  MSG
  338.  
  339.       MSG = ' '
  340.       IF (LDA(7) .NE. 0) THEN
  341.          CDA(7) = LDA(7)
  342.          CDA(6) = 0
  343.       ENDIF
  344.  
  345.       IF (CDA(6) .NE. 0) THEN
  346.         WRITE (*, '(1X, A, I3)') 'Error processing OCI function',
  347.      +   CDA(6)
  348.       ENDIF
  349.  
  350.       CALL OERHMS (LDA, CDA(7), %REF(MSG), 132)
  351.       WRITE (*, '(1X, A)') MSG
  352.  
  353.       RETURN
  354.       END
  355.  
  356.  
  357.       INTEGER FUNCTION LEN_TRIM(STRING)
  358.       CHARACTER*(*) STRING
  359.  
  360.       INTEGER NEXT
  361.  
  362.       DO 10 NEXT = LEN(STRING), 1, -1
  363.         IF (STRING(NEXT : NEXT) .NE. ' ') THEN
  364.           LEN_TRIM = NEXT
  365.           RETURN
  366.         ENDIF
  367. 10    CONTINUE
  368.  
  369.       LEN_TRIM = 0
  370.  
  371.       RETURN
  372.       END
  373.  
  374.