3. Embedded SQL for COBOL : Sample Applications : A Dynamic SQL/Forms Database Browser
 
Share this page                  
A Dynamic SQL/Forms Database Browser
This program lets the user browse data from and insert data into any table in any database, using a dynamically defined form. The program uses Dynamic SQL and Dynamic FRS statements to process the interactive data. You should already have used VIFRED to create a Default Form based on the database table that you want to browse. VIFRED will build a form with fields that have the same names and data types as the columns of the specified database table.
When run, the program prompts the user for the name of the database, the table and the form. The form is profiled using the describe form statement, and the field name, data type and length information is processed. From this information, the program fills in the SQLDA data and null indicator areas, and builds two Dynamic SQL statement strings to select data from and insert data into the database.
The Browse menu item retrieves the data from the database using an SQL cursor associated with the dynamic select statement, and displays that data using the dynamic putform statement. A submenu allows the user to continue with the next row or return to the main menu. The Insert menu item retrieves the data from the form using the dynamic getform statement, and adds the data to the database table using a prepared insert statement. The Save menu item commits the user's changes and, because prepared statements are discarded, reprepares the select and insert statements. When the Quit menu item is selected, all pending changes are rolled back and the program is terminated.
For readability, all Embedded SQL words are in uppercase.
Windows and UNIX
       IDENTIFICATION DIVISION.
       PROGRAM-ID.  DYNAMIC-FRS.
       ENVIRONMENT DIVISION.
       DATA DIVISION.
       WORKING-STORAGE SECTION.
*      Include SQL Communications and Descriptor Areas
       EXEC SQL INCLUDE SQLCA END-EXEC.
       EXEC SQL INCLUDE SQLDA END-EXEC.
       
*      Dynamic SQL SELECT and INSERT statements (documentary only)
       EXEC SQL DECLARE sel_stmt STATEMENT END-EXEC.
       EXEC SQL DECLARE ins_stmt STATEMENT END-EXEC.
*      Cursor declaration for dynamic statement
       EXEC SQL DECLARE csr CURSOR FOR sel_stmt END-EXEC.
       EXEC SQL BEGIN DECLARE SECTION END-EXEC.
*      Database, form and table names
       01 DB-NAME        PIC X(40).
       01 FORM-NAME      PIC X(40).
       01 TABLE-NAME     PIC X(40).
*      Dynamic SQL SELECT and INSERT statement buffers
       01 SEL-BUF        PIC X(1000).
       01 INS-BUF        PIC X(1000).
*      Error status and prompt error return buffer
       01 ERR            PIC S9(8) USAGE COMP.
       01 RET            PIC X.
       EXEC SQL END DECLARE SECTION END-EXEC.
*      DESCRIBE-FORM (form profiler) return state
       01 DESCRIBED          PIC S9(4) USAGE COMP.
          88 DESCRIBE-FAIL   VALUE 0.
          88 DESCRIBE-OK     VALUE 1.
*      Index into SQLVAR table
       01 COLN               PIC S9(4) USAGE COMP.
*      Base data type of SQLVAR item without nullability
       01 BASE-TYPE          PIC S9(4) USAGE COMP.
*      Is a result column type nullable
       01 IS-NULLABLE        PIC S9(4) USAGE COMP.
          88 NOT-NULLABLE   VALUE 0.
          88 NULLABLE       VALUE 1.
*      Global result data storage.  This pool of data includes the
*      maximum number of data items needed to execute a dynamic
*      retrieval or insertion.  There is a table of 1024 integer,
*      decimal and null indicator data items, and a large
*      character string buffer from which sub-strings are
*      allocated.  Floating-point and money types are stored
*      in decimal variables.
       01 RESULT-DATA.
          02 ARRAY-STORAGE OCCURS IISQ-MAX-COLS TIMES.
              03 INTEGERS          PIC S9(9) USAGE COMP-5 SYNC.
              03 DECIMALS          PIC S9(10)V9(8) USAGE COMP-3.
              03 INDICATORS        PIC S9(4) USAGE COMP-5 SYNC.
          02 CHARS                PIC X(3000).
*      Total used length of data buffer
          02 CHAR-CNT             PIC S9(4) USAGE COMP VALUE 1.
*      Current length required from character data buffer
          02 CHAR-CUR             PIC S9(4) USAGE COMP.
*      Buffer for building Dynamic SQL statement string names
       01 NAMES                    PIC X(1000) VALUE SPACES.
       01 NAME-CNT                 PIC S9(4) USAGE COMP VALUE 1.
*      Buffer for collecting Dynamic SQL place holders
       01 MARKS                    PIC X(1000) VALUE SPACES.
       01 MARK-CNT                 PIC S9(4) USAGE COMP VALUE 1.

**
* Procedure Division: DYNAMIC-FRS
*
*     Main body of Dynamic SQL forms application.  Prompt for
*     database, form and table name.  Perform DESCRIBE-FORM
*     to obtain a profile of the form and set up the SQL
*     statements.  Then allow the user to interactively browse
*     the database table and append new data.
**
       PROCEDURE DIVISION.
       EXAMPLE SECTION.
       XBEGIN.
*      Turn on forms system
       EXEC FRS FORMS END-EXEC.
*      Prompt for database name - will abort on errors
       EXEC SQL WHENEVER SQLERROR STOP END-EXEC.
       EXEC FRS PROMPT ('Database name: ', :DB-NAME) END-EXEC.
       EXEC SQL CONNECT :DB-NAME END-EXEC.

       EXEC SQL WHENEVER SQLERROR CALL SQLPRINT END-EXEC.
*      Prompt for table name - later a Dynamic SQL SELECT
*      statement will be built from it.
       EXEC FRS PROMPT ('Table name: ', :TABLE-NAME) END-EXEC.
*      Prompt for form name.  Check forms errors through
*      INQUIRE_FRS.
       EXEC FRS PROMPT ('Form name: ', :FORM-NAME) END-EXEC.
       EXEC FRS MESSAGE 'Loading form ...' END-EXEC.
       EXEC FRS FORMINIT :FORM-NAME END-EXEC.
       EXEC FRS INQUIRE_FRS FRS (:ERR = ERRORNO) END-EXEC.
       IF (ERR > 0) THEN
            EXEC FRS MESSAGE 'Could not load form.
                   Exiting.' END-EXEC
            EXEC FRS ENDFORMS END-EXEC
            EXEC SQL DISCONNECT END-EXEC
            STOP RUN.
*      Commit any work done so far - access of forms catalogs
       EXEC SQL COMMIT END-EXEC.
*      Describe the form and build the SQL statement strings
       PERFORM DESCRIBE-FORM THROUGH END-DESCRIBE.
       IF (DESCRIBE-FAIL) THEN
           EXEC FRS MESSAGE 'Could not describe form.  Exiting.'
               END-EXEC
           EXEC FRS ENDFORMS END-EXEC
           EXEC SQL DISCONNECT END-EXEC
           STOP RUN.
*      PREPARE the SELECT and INSERT statements that correspond
*      to the menu items Browse and Insert.  If the Save menu item
*      is chosen the statements are reprepared.
       EXEC SQL PREPARE sel_stmt FROM :SEL-BUF END-EXEC.
       MOVE SQLCODE TO ERR.
       EXEC SQL PREPARE ins_stmt FROM :INS-BUF END-EXEC.
       IF (ERR < 0) OR (SQLCODE < 0) THEN
           EXEC FRS MESSAGE 
                'Could not prepare SQL statements.
                           Exiting.' END-EXEC
           EXEC FRS ENDFORMS END-EXEC
           EXEC SQL DISCONNECT END-EXEC
           STOP RUN.
*      Display the form and interact with user, allowing browsing
*      and the inserting of new data.
       EXEC FRS DISPLAY :FORM-NAME FILL END-EXEC
       EXEC FRS INITIALIZE END-EXEC
       EXEC FRS ACTIVATE MENUITEM 'Browse' END-EXEC
       EXEC FRS BEGIN END-EXEC
*      Retrieve data and display the first row on the form,
*      allowing the user to browse through successive rows.  If
*      data types from the database table are not consistent with
*      data descriptions obtained from the form, a retrieval
*      error will occur.  Inform the user of this or other errors.
*  
*      Note that the data will return sorted by the first field
*      that was described, as the SELECT statement, sel_stmt,
*      included an ORDER BY clause.
             EXEC SQL OPEN csr FOR READONLY END-EXEC.
*      Fetch and display each row
       FETCH-NEXT-ROW.
             IF (SQLCODE NOT= 0) THEN
                  GO TO END-FETCH-NEXT.
             EXEC SQL FETCH csr USING DESCRIPTOR :SQLDA END-EXEC.
             IF (SQLCODE NOT= 0) THEN
                  EXEC SQL CLOSE csr END-EXEC
                  EXEC FRS PROMPT NOECHO ('No more rows :', :RET)
                       END-EXEC
                  EXEC FRS CLEAR FIELD ALL END-EXEC
                  EXEC FRS RESUME END-EXEC.
             EXEC FRS PUTFORM :FORM-NAME USING DESCRIPTOR :SQLDA
                 END-EXEC.
             EXEC FRS INQUIRE_FRS FRS (:ERR = ERRORNO) END-EXEC.
             IF (ERR > 0) THEN
                  EXEC SQL CLOSE csr END-EXEC
                  EXEC FRS RESUME END-EXEC.
*      Display data before prompting user with submenu
             EXEC FRS REDISPLAY END-EXEC.
             EXEC FRS SUBMENU END-EXEC
             EXEC FRS ACTIVATE MENUITEM 'Next', FRSKEY4 END-EXEC
             EXEC FRS BEGIN END-EXEC
*      Continue with cursor loop
                  EXEC FRS MESSAGE 'Next row ...' END-EXEC.
                  EXEC FRS CLEAR FIELD ALL END-EXEC.
             EXEC FRS END END-EXEC
             EXEC FRS ACTIVATE MENUITEM 'End', FRSKEY3 END-EXEC
             EXEC FRS BEGIN END-EXEC
                 EXEC SQL CLOSE csr END-EXEC.
                 EXEC FRS CLEAR FIELD ALL END-EXEC.
                 EXEC FRS RESUME END-EXEC.
             EXEC FRS END END-EXEC
*      Fetch next row
             GO TO FETCH-NEXT-ROW.
*      End of row processing
       END-FETCH-NEXT.
             CONTINUE.
       EXEC FRS END END-EXEC
       EXEC FRS ACTIVATE MENUITEM 'Insert' END-EXEC
       EXEC FRS BEGIN END-EXEC
           EXEC FRS GETFORM :FORM-NAME USING DESCRIPTOR :SQLDA
                END-EXEC.
           EXEC FRS INQUIRE_FRS FRS (:ERR = ERRORNO) END-EXEC.
           IF (ERR > 0) THEN
                EXEC FRS CLEAR FIELD ALL END-EXEC
                EXEC FRS RESUME END-EXEC.
 
                EXEC SQL EXECUTE ins_stmt USING DESCRIPTOR :SQLDA
                   END-EXEC.
                IF (SQLCODE < 0) OR (SQLERRD(3) = 0) THEN
                EXEC FRS PROMPT NOECHO 
                     ('No rows inserted :', :RET) END-EXEC
           ELSE
                EXEC FRS PROMPT NOECHO
                    ('One row inserted :', :ret) END-EXEC.
        EXEC FRS END END-EXEC
        EXEC FRS ACTIVATE MENUITEM 'Save' END-EXEC
        EXEC FRS BEGIN END-EXEC
*        COMMIT any changes and then re-PREPARE the SELECT and
*        INSERT statements as the COMMIT statements discards them.
               EXEC SQL COMMIT END-EXEC.
               EXEC SQL PREPARE sel_stmt FROM :SEL-BUF END-EXEC.
               MOVE SQLCODE TO ERR.
               EXEC SQL PREPARE ins_stmt FROM :INS-BUF END-EXEC.
               IF (ERR < 0) OR (SQLCODE < 0) THEN
                   EXEC FRS PROMPT NOECHO
                        ('Could not reprepare SQL
                                    statements :', :RET)
                         END-EXEC
                   EXEC FRS BREAKDISPLAY END-EXEC.
       EXEC FRS END END-EXEC
       EXEC FRS ACTIVATE MENUITEM 'Clear' END-EXEC
       EXEC FRS BEGIN END-EXEC
               EXEC FRS CLEAR FIELD ALL END-EXEC.
       EXEC FRS END END-EXEC
       EXEC FRS ACTIVATE MENUITEM 'Quit', FRSKEY2 END-EXEC
       EXEC FRS BEGIN END-EXEC
             EXEC SQL ROLLBACK END-EXEC.
             EXEC FRS BREAKDISPLAY END-EXEC.
       EXEC FRS END END-EXEC
       EXEC FRS FINALIZE END-EXEC.
       EXEC FRS ENDFORMS END-EXEC.
       EXEC SQL DISCONNECT END-EXEC.
       STOP RUN.
**
* Paragraph: DESCRIBE-FORM
*
*      Profile the specified form for name and data type
*      information.  Using the DESCRIBE FORM statement, the SQLDA
*      is loaded with field information from the form.  This h
*      paragraph (together with the DESCRIBE-COLUMN paragraph) n
*      processes the form information to allocate result storage,
*      point at storage for dynamic FRS
*      data retrieval and assignment, and build SQL statements
*      strings for subsequent dynamic SELECT and INSERT
*      statements.  For example, assume the form (and table) 'emp'
*      has the following fields:
*                Field Name    Type     Nullable?
*                ----------    ----     ---------
*                name          char(10)  No
*                age           integer4  Yes
*                salary        money     Yes
*
*        Based on 'emp', this paragraph will construct the SQLDA.
*        The paragraph allocates variables from a result variable
*        pool (integers, floats and a large character string
*        space).  The SQLDATA and SQLIND fields are pointed at the
*        addresses of the result variables in the pool.  The
*        following SQLDA is built:
*
*                SQLVAR(1)
*                         SQLTYPE  =  CHAR TYPE
*                         SQLLEN   =  10
*                         SQLDATA  =  pointer into CHARS buffer
*                         SQLIND   =  null
*                         SQLNAME  =  'name'
*                SQLVAR(2)
*                         SQLTYPE   = - INTEGER TYPE
*                         SQLLEN    = 4
*                         SQLDATA   = address of INTEGERS(2)
*                         SQLIND    = address of INDICATORS(2)
*                         SQLNAME   = 'age'
*                SQLVAR(3)
*                         SQLTYPE   = - DECIMAL TYPE
*                         SQLLEN    = 4616 (see below)
*                         SQLDATA   = address of DECIMALS(3)
*                         SQLIND    = address of INDICATORS(3)
*                         SQLNAME   = 'salary'
*
*      This paragraph also builds two dynamic SQL statements
*      strings.
*      Note that the paragraph should be extended to verify that
*      the statement strings do fit into the statement buffers
*      (this was not done in this example).  The above example
*      would construct the following statement strings:
*
*        'SELECT name, age, salary FROM emp ORDER BY name'
*        'INSERT INTO emp (name, age, salary) VALUES (?, ?, ?)'
*
*      This paragraph sets DESCRIBE-OK if it succeeds, and
*      DESCRIBE-FAIL if there was some sort of initialization
*      error.
**
       DESCRIBE-FORM.
*      Initialize the SQLDA and DESCRIBE the form.  If we cannot
*      fully describe the form (our SQLDA is too small) then
*      report an error and return.
       SET DESCRIBE-OK TO TRUE.
       MOVE IISQ-MAX-COLS TO SQLN.
       EXEC FRS DESCRIBE FORM :FORM-NAME ALL INTO
                            :SQLDA END-EXEC.
       EXEC FRS INQUIRE_FRS FRS (:ERR = ERRORNO) END-EXEC.
       IF (ERR > 0) THEN
           SET DESCRIBE-FAIL TO TRUE
           GO TO END-DESCRIBE.
       IF (SQLD > SQLN) THEN
           EXEC FRS PROMPT NOECHO
                 ('SQLDA is too small for form :', :RET) END-EXEC
           SET DESCRIBE-FAIL TO TRUE
            GO TO END-DESCRIBE.
       IF (SQLD = 0) THEN
            EXEC FRS PROMPT NOECHO
            ('There are no fields in the form :', :RET) END-EXEC
            SET DESCRIBE-FAIL TO TRUE
            GO TO END-DESCRIBE.
*      For each field determine the size and type of the
*      result data area.   This is done by DESCRIBE-COLUMN.
*      If a table field type is returned then issue an error.
*
*      Also, for each field add the field name to the 'NAMES'
*      buffer and the SQL place holders '?' to the 'MARKS'
*      buffer, which will be used to build the final SELECT and
*      INSERT statements.
       PERFORM DESCRIBE-COLUMN
             VARYING COLN FROM 1 BY 1
             UNTIL (COLN > SQLD) OR (DESCRIBE-FAIL).
*      At this point we've processed all columns for data type
*      information.
*      Create final SELECT and INSERT statements.  For the SELECT
*      statement ORDER BY the first field.
       STRING "SELECT " NAMES(1: NAME-CNT) " FROM "
             TABLE-NAME " ORDER BY "
             SQLNAMEC(1)(1: SQLNAMEL(1))
             DELIMITED BY SIZE INTO SEL-BUF.
       STRING "INSERT INTO " TABLE-NAME "("
             NAMES(1: NAME-CNT) ") VALUES ("
             MARKS(1: MARK-CNT) ")"
             DELIMITED BY SIZE INTO INS-BUF.
       END-DESCRIBE.
             EXIT.
 
**
*      Paragraph: DESCRIBE-COLUMN
*
*      When setting up data for the SQLDA result data items are
*      chosen out of a pool of variables.  The SQLDATA and SQLIND
*      fields are pointed at the addresses of the result data
*      items and indicators as described in paragraph
*      DESCRIBE-FORM.
*
*      Field names are collected for the building of the Dynamic
*      SQL statement strings as described for paragraph
*      DESCRIBE-FORM.
*
*      Paragraph sets DESCRIBE-FAIL if it fails.
**
       DESCRIBE-COLUMN.
*      Determine the data type of the field and to where SQLDATA
*      and SQLIND must point in order to retrieve type-compatible
*      results.
*      First find the base type of the current column.
*      Normally you should clear the SQLIND pointer if it
*      is not being used using the SET TO NULL statement.  At the
*      time of this writing, however, SET pointer-item TO NULL
*      was not accepted.  The pointer will be ignored by
*      Ingres if the SQLTYPE is positive.
       IF (SQLTYPE(COLN) > 0) THEN
           MOVE SQLTYPE(COLN) TO BASE-TYPE
           SET NOT-NULLABLE TO TRUE
           SET SQLIND(COLN) TO NULL
       ELSE
           COMPUTE BASE-TYPE = 0 - SQLTYPE(COLN)
           SET NULLABLE TO TRUE
           SET SQLIND(COLN) TO ADDRESS OF INDICATORS(COLN)
       END-IF.
*      Collapse all different types into one of integer,
*      float or character.
*      Integer data uses 4-byte COMP.
       IF (BASE-TYPE = IISQ-INT-TYPE) THEN
           MOVE IISQ-INT-TYPE TO SQLTYPE(COLN)
           MOVE 4 TO SQLLEN(COLN)
           SET SQLDATA(COLN) TO ADDRESS OF INTEGERS(COLN)
*      Money and floating-point or decimal use COMP-3.
*
 
*      You must encode precision and length when setting
*      SQLLEN for a decimal data type.  Use the formula: SQLLEN =
*      (256 * p+s) where p is the Ingres precision and s 
*      is scale of the decimal host variable.DEC-DATA is defined
*      as PIC S9(10)V9(8), so p = 10+8 (Ingres precision 
*      is the total number of digits) and s= 8.  Therefore, SQLLEN
*      - (256 * 18 + 8) = 4616.
       ELSE IF (BASE-TYPE = IISQ-MNY-TYPE)
            OR (BASE-TYPE = IISQ-DEC-TYPE)
            OR (BASE-TYPE = IISQ-FLT-TYPE) THEN
              MOVE IISQ-DEC-TYPE TO SQLTYPE(COLN)
              MOVE 4616 TO SQLLEN(COLN)
              SET SQLDATA(COLN) TO ADDRESS OF DECIMALS(COLN)
*      Dates, fixed and varying-length character strings use
*      character data.
       ELSE IF (BASE-TYPE = IISQ-DTE-TYPE)
             OR (BASE-TYPE = IISQ-CHA-TYPE)
             OR (BASE-TYPE = IISQ-VCH-TYPE) THEN
 
*      Fix up the lengths of dates and determine the length of
*      the sub-string required from the large character string
*      buffer.
             IF (BASE-TYPE = IISQ-DTE-TYPE) THEN
                  MOVE IISQ-DTE-LEN TO SQLLEN(COLN)
             END-IF
 
             MOVE IISQ-CHA-TYPE TO SQLTYPE(COLN)
             MOVE SQLLEN(COLN) TO CHAR-CUR
 
*      If we do not have enough character space left display an error.
             IF ((CHAR-CNT + CHAR-CUR) > 3000) THEN
                  EXEC FRS PROMPT NOECHO
                   ('Character pool buffer overflow :', :RET) END-EXEC
                  SET DESCRIBE-FAIL TO TRUE
             ELSE
*      There is enough space so point at the start of the
*      corresponding sub-string.  Allocate space out of character
*      buffer and accumulate the currently used character space.
                SET SQLDATA(COLN) TO ADDRESS OF CHARS(CHAR-CNT:)
                ADD CHAR-CUR TO CHAR-CNT
           END-IF
*      Table fields are not allowed
       ELSE IF (BASE-TYPE = IISQ-TBL-TYPE) THEN
           EXEC FRS PROMPT NOECHO
               ('Table field found in form :', :RET) END-EXEC
           SET DESCRIBE-FAIL TO TRUE
*      Unknown data type
       ELSE
           EXEC FRS PROMPT NOECHO
                   ('Invalid field type :', :RET) END-EXEC
           SET DESCRIBE-FAIL TO TRUE
       END-IF.
*      If nullable negate the data type
       IF (NULLABLE) THEN
            COMPUTE SQLTYPE(COLN) = 0 - SQLTYPE(COLN)
       END-IF.
*      Store field names and place holders (separated by commas)
*      for the SQL statements.
       IF (COLN > 1) THEN
           MOVE "," TO NAMES(NAME-CNT:1)
           ADD 1 TO NAME-CNT
           MOVE "," TO MARKS(MARK-CNT:1)
           ADD 1 TO MARK-CNT.
       END-IF.
       MOVE SQLNAMEC(COLN)(1:SQLNAMEL(COLN)) TO
                   NAMES(NAME-CNT:SQLNAMEL(COLN)).
       ADD SQLNAMEL(COLN) TO NAME-CNT.
       MOVE "?" TO MARKS(MARK-CNT:1).
       ADD 1 TO MARK-CNT. 
 
VMS
IDENTIFICATION DIVISION.
PROGRAM-ID. DYNAMIC-FRS.
ENVIRONMENT DIVISION.
DATA DIVISION.
WORKING-STORAGE SECTION.
 Include SQL Communications and Descriptor Areas
  EXEC SQL INCLUDE SQLCA END-EXEC.
  EXEC SQL INCLUDE SQLDA END-EXEC.
* Dynamic SQL SELECT and INSERT statements (documentary only)
  EXEC SQL DECLARE sel_stmt STATEMENT END-EXEC.
  EXEC SQL DECLARE ins_stmt STATEMENT END-EXEC.
* Cursor declaration for dynamic statement
 EXEC SQL DECLARE csr CURSOR FOR sel_stmt END-EXEC.
EXEC SQL BEGIN DECLARE SECTION END-EXEC.
* Database, form and table names
    01 DB-NAME                PIC X(40).
    01 FORM-NAME              PIC X(40).
    01 TABLE-NAME             PIC X(40).
* Dynamic SQL SELECT and INSERT statement buffers
    01 SEL-BUF                PIC X(1000).
    01 INS-BUF                PIC X(1000).
* Error status and prompt error return buffer
    01 ERR                    PIC S9(8) USAGE COMP.
    01 RET                    PIC X.
EXEC SQL END DECLARE SECTION END-EXEC.
* DESCRIBE-FORM (form profiler) return state
  01 DESCRIBED             PIC S9(4) USAGE COMP.
      88 DESCRIBE-FAIL      VALUE 0.
      88 DESCRIBE-OK        VALUE 1.
* Index into SQLVAR table
  01 COL                    PIC S9(4) USAGE COMP.
* Base data type of SQLVAR item without nullability
  01 BASE-TYPE              PIC S9(4) USAGE COMP.
* Is a result column type nullable
  01 IS-NULLABLE            PIC S9(4) USAGE COMP.
      88 NOT-NULLABLE        VALUE 0.
      88 NULLABLE            VALUE 1.
 
* Global result data storage. This pool of data includes the maximum
* number of data items needed to execute a dynamic retrieval or
* insertion. There is a table of 1024 integer, floating-point and
* null indicator data items, and a large character string buffer
* from which sub-strings are allocated.
  01 RESULT-DATA.
     02 INTEGERS        PIC S9(9) USAGE COMP OCCURS 1024 TIMES.
     02 DECIMALS        PIC S9(10)V9(8) USAGE COMP-3 OCCURS 1024 TIMES.
     02 INDICATORS      PIC S9(4) USAGE COMP OCCURS 1024 TIMES.
     02 CHARS           PIC X(3000).
* Total used length of data buffer
  01 CHAR-CNT           PIC S9(4) USAGE COMP VALUE 1.
* Current length required from character data buffer
  01 CHAR-CUR           PIC S9(4) USAGE COMP.
* Buffer for building Dynamic SQL statement string names
  01 NAMES              PIC X(1000) VALUE SPACES.
  01 NAME-CNT           PIC S9(4) USAGE COMP VALUE 1.
* Buffer for collecting Dynamic SQL place holders
  01 MARKS              PIC X(1000) VALUE SPACES.
  01 MARK-CNT           PIC S9(4) USAGE COMP VALUE 1.
**
* Procedure Division: DYNAMIC-FRS
*
* Main body of Dynamic SQL forms application. Prompt for database,
* form and table name. Perform DESCRIBE-FORM to obtain a profile
* of the form and set up the SQL statements. Then allow the user
* to interactively browse the database table and append new data.
**
PROCEDURE DIVISION.
SBEGIN.
* Turn on forms system
      EXEC FRS FORMS END-EXEC.
* Prompt for database name - will abort on errors
      EXEC SQL WHENEVER SQLERROR STOP END-EXEC.
      EXEC FRS PROMPT ('Database name: ', :DB-NAME) END-EXEC.
      EXEC SQL CONNECT :DB-NAME END-EXEC.
      EXEC SQL WHENEVER SQLERROR CALL SQLPRINT END-EXEC.
* Prompt for table name - later a Dynamic SQL SELECT statement
* will be built from it.
      EXEC FRS PROMPT ('Table name: ', :TABLE-NAME) END-EXEC.
* Prompt for form name. Check forms errors reported through
* INQUIRE_FRS.
      EXEC FRS PROMPT ('Form name: ', :FORM-NAME) END-EXEC.
      EXEC FRS MESSAGE 'Loading form ...' END-EXEC.
      EXEC FRS FORMINIT :FORM-NAME END-EXEC.
      EXEC FRS INQUIRE_FRS FRS (:ERR = ERRORNO) END-EXEC.
      IF (ERR > 0) THEN
             EXEC FRS MESSAGE 'Could not load form. Exiting.' END-EXEC
             EXEC FRS ENDFORMS END-EXEC
             EXEC SQL DISCONNECT END-EXEC
             STOP RUN.
* Commit any work done so far - access of forms catalogs
      EXEC SQL COMMIT END-EXEC.
* Describe the form and build the SQL statement strings
      PERFORM DESCRIBE-FORM THROUGH END-DESCRIBE.
      IF (DESCRIBE-FAIL) THEN
           EXEC FRS MESSAGE 'Could not describe form. Exiting.'
               END-EXEC
           EXEC FRS ENDFORMS END-EXEC
           EXEC SQL DISCONNECT END-EXEC
          STOP RUN.
* PREPARE the SELECT and INSERT statements that correspond to the
* menu items Browse and Insert. If the Save menu item is chosen
* the statements are reprepared.
      EXEC SQL PREPARE sel_stmt FROM :SEL-BUF END-EXEC.
      MOVE SQLCODE TO ERR.
      EXEC SQL PREPARE ins_stmt FROM :INS-BUF END-EXEC.
      IF (ERR < 0) OR (SQLCODE < 0) THEN
           EXEC FRS MESSAGE
                 'Could not prepare SQL statements. Exiting.' END-EXEC
           EXEC FRS ENDFORMS END-EXEC
           EXEC SQL DISCONNECT END-EXEC
           STOP RUN.
* Display the form and interact with user, allowing browsing
* and the inserting of new data.
      EXEC FRS DISPLAY :FORM-NAME FILL END-EXEC
      EXEC FRS INITIALIZE END-EXEC
      EXEC FRS ACTIVATE MENUITEM 'Browse' END-EXEC
      EXEC FRS BEGIN END-EXEC
* Retrieve data and display the first row on the form, allowing
* the user to browse through successive rows. If data types
* from the database table are not consistent with data descriptions
* obtained from the form, a retrieval error will occur. Inform
* the user of this or other errors.
* Note that the data will return sorted by the first field that
* was described, as the SELECT statement, sel_stmt, included an
* ORDER BY clause.
      EXEC SQL OPEN csr FOR READONLY END-EXEC.
* Fetch and display each row
FETCH-NEXT-ROW.
            IF (SQLCODE NOT= 0) THEN
                GO TO END-FETCH-NEXT.
            EXEC SQL FETCH csr USING DESCRIPTOR :SQLDA END-EXEC.
            IF (SQLCODE NOT= 0) THEN
                EXEC SQL CLOSE csr END-EXEC
                EXEC FRS PROMPT NOECHO ('No more rows :', :RET)
                   END-EXEC
                EXEC FRS CLEAR FIELD ALL END-EXEC
                EXEC FRS RESUME END-EXEC.
            EXEC FRS PUTFORM :FORM-NAME USING DESCRIPTOR :SQLDA
                END-EXEC.
            EXEC FRS INQUIRE_FRS FRS (:ERR = ERRORNO) END-EXEC.
            IF (ERR > 0) THEN
                 EXEC SQL CLOSE csr END-EXEC
                 EXEC FRS RESUME END-EXEC.
* Display data before prompting user with submenu
            EXEC FRS REDISPLAY END-EXEC.
            EXEC FRS SUBMENU END-EXEC
            EXEC FRS ACTIVATE MENUITEM 'Next', FRSKEY4 END-EXEC
            EXEC FRS BEGIN END-EXEC
* Continue with cursor loop
                  EXEC FRS MESSAGE 'Next row ...' END-EXEC.
                  EXEC FRS CLEAR FIELD ALL END-EXEC.
            EXEC FRS END END-EXEC
            EXEC FRS ACTIVATE MENUITEM 'End', FRSKEY3 END-EXEC
            EXEC FRS BEGIN END-EXEC
                  EXEC SQL CLOSE csr END-EXEC.
                  EXEC FRS CLEAR FIELD ALL END-EXEC.
                  EXEC FRS RESUME END-EXEC.
            EXEC FRS END END-EXEC
* Fetch next row
            GO TO FETCH-NEXT-ROW.
* End of row processing
END-FETCH-NEXT.
            CONTINUE.
      EXEC FRS END END-EXEC
      EXEC FRS ACTIVATE MENUITEM 'Insert' END-EXEC
      EXEC FRS BEGIN END-EXEC
         EXEC FRS GETFORM :FORM-NAME USING DESCRIPTOR :SQLDA END-EXEC.
         EXEC FRS INQUIRE_FRS FRS (:ERR = ERRORNO) END-EXEC.
         IF (ERR > 0) THEN
              EXEC FRS CLEAR FIELD ALL END-EXEC
              EXEC FRS RESUME END-EXEC.
         EXEC SQL EXECUTE ins_stmt USING DESCRIPTOR :SQLDA END-EXEC.
         IF (SQLCODE < 0) OR (SQLERRD(3) = 0) THEN
               EXEC FRS PROMPT NOECHO ('No rows inserted :', :RET)
                 END-EXEC
         ELSE
         EXEC FRS PROMPT NOECHO ('One row inserted :', :ret)
               END-EXEC.
      EXEC FRS END END-EXEC
      EXEC FRS ACTIVATE MENUITEM 'Save' END-EXEC
      EXEC FRS BEGIN END-EXEC
* COMMIT any changes and then re-PREPARE the SELECT and INSERT
* statements as the COMMIT statements discards them.
              EXEC SQL COMMIT END-EXEC.
              EXEC SQL PREPARE sel_stmt FROM :SEL-BUF END-EXEC.
              MOVE SQLCODE TO ERR.
              EXEC SQL PREPARE ins_stmt FROM :INS-BUF END-EXEC.
              IF (ERR < 0) OR (SQLCODE < 0) THEN
                    EXEC FRS PROMPT NOECHO
                        ('Could not reprepare SQL statements :', :RET)
                        END-EXEC
                    EXEC FRS BREAKDISPLAY END-EXEC.
      EXEC FRS END END-EXEC
      EXEC FRS ACTIVATE MENUITEM 'Clear' END-EXEC
      EXEC FRS BEGIN END-EXEC
           EXEC FRS CLEAR FIELD ALL END-EXEC.
      EXEC FRS END END-EXEC
      EXEC FRS ACTIVATE MENUITEM 'Quit', FRSKEY2 END-EXEC
      EXEC FRS BEGIN END-EXEC
            EXEC SQL ROLLBACK END-EXEC.
            EXEC FRS BREAKDISPLAY END-EXEC.
      EXEC FRS END END-EXEC
      EXEC FRS FINALIZE END-EXEC.
      EXEC FRS ENDFORMS END-EXEC.
      EXEC SQL DISCONNECT END-EXEC.
      STOP RUN.
**
* Paragraph: DESCRIBE-FORM
*
* Profile the specified form for name and data type information.
* Using the DESCRIBE FORM statement, the SQLDA is loaded with
* field information from the form. This paragraph (together with
* the DESCRIBE-COLUMN paragraph) processes the form information
* to allocate result storage, point at storage for dynamic FRS
* data retrieval and assignment, and build SQL statements strings
* for subsequent dynamic SELECT and INSERT statements. For example,
* assume the form (and table) 'emp' has the following fields:

* Field Name Type    Nullable?
* ---------- ----    ---------
* name      char(10)  No
* age       integer4  Yes
* salary    money     Yes
*
* Based on 'emp', this paragraph will construct the SQLDA.
* The paragraph allocates variables from a result variable
* pool (integers, decimals and a large character string space).
* The SQLDATA and SQLIND fields are pointed at the addresses
* of the result variables in the pool. The following SQLDA
* is built:
*
*       SQLVAR(1)
*           SQLTYPE = CHAR TYPE
*           SQLLEN  = 10
*           SQLDATA = pointer into CHARS buffer
*           SQLIND  = null
*           SQLNAME = 'name'
*       SQLVAR(2)
*           SQLTYPE = - INTEGER TYPE
*           SQLLEN  = 4
*           SQLDATA = address of INTEGERS(2)
*           SQLIND  = address of INDICATORS(2)
*           SQLNAME = 'age'
*       SQLVAR(3)
*           SQLTYPE = - DECIMAL TYPE
*           SQLLEN  = 4616 (see below)
*           SQLDATA = address of DECIMALS(3)
*           SQLIND  = address of INDICATORS(3)
*           SQLNAME = 'salary'
*
 
* This paragraph also builds two dynamic SQL statements strings.
* Note that the paragraph should be extended to verify that the
* statement strings do fit into the statement buffers (this was
* not done in this example). The above example would construct
* the following statement strings:
*
* 'SELECT name, age, salary FROM emp ORDER BY name'
* 'INSERT INTO emp (name, age, salary) VALUES (?, ?, ?)'
*
* This paragraph sets DESCRIBE-OK if it succeeds, and
* DESCRIBE-FAIL if there was some sort of initialization error.
**
DESCRIBE-FORM.
* Initialize the SQLDA and DESCRIBE the form. If we cannot fully
* describe the form (our SQLDA is too small) then report an error
* and return.
          SET DESCRIBE-OK TO TRUE.
          MOVE 1024 TO SQLN.
          EXEC FRS DESCRIBE FORM :FORM-NAME ALL INTO :SQLDA END-EXEC.
          EXEC FRS INQUIRE_FRS FRS (:ERR = ERRORNO) END-EXEC.
          IF (ERR > 0 ) THEN
                SET DESCRIBE-FAIL TO TRUE
                GO TO END-DESCRIBE.
          IF (SQLD > SQLN) THEN
                EXEC FRS PROMPT NOECHO
                     ('SQLDA is too small for form :', :RET) END-EXEC
                SET DESCRIBE-FAIL TO TRUE
                GO TO END-DESCRIBE.
          IF (SQLD = 0) THEN
                EXEC FRS PROMPT NOECHO
                  ('There are no fields in the form :', :RET) END-EXEC
                SET DESCRIBE-FAIL TO TRUE
                GO TO END-DESCRIBE.
 
* For each field determine the size and type of the result data area.
* This is done by DESCRIBE-COLUMN.
* If a table field type is returned then issue an error.
*
* Also, for each field add the field name to the 'NAMES' buffer
* and the SQL place holders '?' to the 'MARKS' buffer, which
* will be used to build the final SELECT and INSERT statements.
      PERFORM DESCRIBE-COLUMN
                VARYING COL FROM 1 BY 1
                UNTIL (COL > SQLD) OR (DESCRIBE-FAIL).
* At this point we've processed all columns for data type
* information. Create final SELECT and INSERT statements. For the
* SELECT statement ORDER BY the first field.
     STRING "SELECT " NAMES(1: NAME-CNT) " FROM " TABLE-NAME
               " ORDER BY " SQLNAMEC(1)(1: SQLNAMEL(1))
               DELIMITED BY SIZE INTO SEL-BUF.
     STRING "INSERT INTO " TABLE-NAME "(" NAMES(1: NAME-CNT)
               ") VALUES (" MARKS(1: MARK-CNT) ")"
              DELIMITED BY SIZE INTO INS-BUF.
END-DESCRIBE.
      EXIT.
**
* Paragraph: DESCRIBE-COLUMN
*
* When setting up data for the SQLDA result data items are chosen
* out of a pool of variables. The SQLDATA and SQLIND fields are
* pointed at the addresses of the result data items and indicators
* as described in paragraph DESCRIBE-FORM.

* Field names are collected for the building of the Dynamic SQL
* statement strings as described for paragraph DESCRIBE-FORM.
*
* Paragraph sets DESCRIBE-FAIL if it fails.
**
DESCRIBE-COLUMN.
* Determine the data type of the filed and to where SQLDATA and
* SQLIND must point in order to retrieve type-compatible results.
* First find the base type of the current column.
            IF (SQLTYPE(COL) > 0) THEN
            MOVE SQLTYPE(COL) TO BASE-TYPE
            SET NOT-NULLABLE TO TRUE
            MOVE 0 TO SQLIND(COL)
      ELSE
            COMPUTE BASE-TYPE = 0 - SQLTYPE(COL)
            SET NULLABLE TO TRUE
            SET SQLIND(COL) TO REFERENCE INDICATORS(COL).
* Collapse all different types into one of integer, float
* or character.
* Integer data uses 4-byte COMP.
      IF (BASE-TYPE = 30) THEN
            IF (NOT-NULLABLE) THEN
                  MOVE 30 TO SQLTYPE(COL)
            ELSE
                  MOVE -30 TO SQLTYPE(COL)
            END-IF
            MOVE 4 TO SQLLEN(COL)
            SET SQLDATA(COL) TO REFERENCE INTEGERS(COL)
* Money and floating-point or decimal data use COMP-3.
* You must encode precision and length when setting SQLLEN
* for a decimal data type. Use the formula: SQLLEN = (256 *p+s)
* where p is the Ingres precision and s is scale of the decimal
* host variable. DEC-DATA is defined as PIC S9(10)V9(8), so
* p = 10 + 8 (Ingres precision is the total number of digits)
* and s= 8. Therefore, SQLLEN = (256 * 18+8) = 4616.
      ELSE IF (BASE-TYPE = 5)
           OR (BASE-TYPE = 10)
           OR (BASE-TYPE = 31) THEN
          IF (NOT-NULLABLE) THEN
                MOVE 10 TO SQLTYPE(COL)
          ELSE
                MOVE -10 TO SQLTYPE(COL)
          END-IF
          MOVE 4616 TO SQLLEN(COL)
          SET SQLDATA(COL) TO REFERENCE DECIMALS(COL)
* Dates, fixed and varying-length character strings use
* character data.
      ELSE IF (BASE-TYPE = 3)
          OR  (BASE-TYPE = 20)
          OR  (BASE-TYPE = 21) THEN
* Fix up the lengths of dates and determine the length of the
* sub-string required from the large character string buffer.
          IF (BASE-TYPE = 3) THEN
              MOVE 25 TO SQLLEN(COL)
          END-IF
          IF (NOT-NULLABLE) THEN
              MOVE 20 TO SQLTYPE(COL)
          ELSE
              MOVE -20 TO SQLTYPE(COL)
          END-IF
          MOVE SQLLEN(COL) TO CHAR-CUR
* If we do not have enough character space left display an error.
          IF ((CHAR-CNT + CHAR-CUR) > 3000) THEN
              EXEC FRS PROMPT NOECHO
                  ('Character pool buffer overflow :', :RET) END-EXEC
              SET DESCRIBE-FAIL TO TRUE
          ELSE
* There is enough space so point at the start of the corresponding
* sub-string. Allocate space out of character buffer and accumulate
* the currently used character space.
              SET SQLDATA(COL) TO REFERENCE CHARS(CHAR-CNT:)
              ADD CHAR-CUR TO CHAR-CNT
          END-IF
* Table fields are not allowed
      ELSE IF (BASE-TYPE = 52) THEN
            EXEC FRS PROMPT NOECHO
                  ('Table field found in form :', :RET) END-EXEC
            SET DESCRIBE-FAIL TO TRUE
* Unknown data type
      ELSE
            EXEC FRS PROMPT NOECHO ('Invalid field type :', :RET)
                END-EXEC
            SET DESCRIBE-FAIL TO TRUE
      END-IF.
* Store field names and place holders (separated by commas)
* for the SQL statements.
     IF (COL > 1) THEN
          MOVE "," TO NAMES(NAME-CNT:1)
          ADD 1 TO NAME-CNT
          MOVE "," TO MARKS(MARK-CNT:1)
          ADD 1 TO MARK-CNT.
     END-IF.
     MOVE SQLNAMEC(COL)(1:SQLNAMEL(COL)) TO
              NAMES(NAME-CNT:SQLNAMEL(COL)).
     ADD SQLNAMEL(COL) TO NAME-CNT.
     MOVE "?" TO MARKS(MARK-CNT:1).
     ADD 1 TO MARK-CNT.