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.
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.
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 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).
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).
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.
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.
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.
01 COLN PIC S9(4) USAGE COMP.
* Base data type of SQLVAR item without nullability
01 BASE-TYPE PIC S9(4) USAGE COMP.
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.
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
* 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.
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.
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.
**
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.
**
*
* 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.
EXAMPLE SECTION.
XBEGIN.
* Turn on forms system
EXEC FRS FORMS END-EXEC.
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.
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.
* 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.
* 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.
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.
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.
* 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.
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.
* 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
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.
*
* 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.
* 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.
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 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.
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 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 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 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.
GO TO FETCH-NEXT-ROW.
* End of row processing
END-FETCH-NEXT.
CONTINUE.
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 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.
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
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.
* 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 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 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.
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:
*
*
* 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
*
* ---------- ---- ---------
* 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:
* 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'
* 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:
*
* 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 (?, ?, ?)'
* '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
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.
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.
IF (NULLABLE) THEN
COMPUTE SQLTYPE(COLN) = 0 - SQLTYPE(COLN)
END-IF.
* Store field names and place holders (separated by commas)
* for the SQL statements.
* 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 "," 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.
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.
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.
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).
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.
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.
* 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.
**
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.
**
*
* 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.
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.
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.
* 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.
*
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
* 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 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.
**
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:
*
* 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'
*
* 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:
*
* 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 (?, ?, ?)'
*
* '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-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.
* 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.
*
* 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.
**
* 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.
**
* 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)
* 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.
* 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.
Last modified date: 01/30/2023