C

C Program: Dynamic_FRS
C Purpose: Main body of Dynamic SQL forms application. Prompt for
C          database, form and table name. Call Describe_Form 
C          to obtain a profile of the form and set up the SQL
C          statements. Then allow the user to interactively browse
C          database table and append new data.
C

C
C The UNIX compiler will generate - "Warning: %LOC function
C       treated as LOC". This is for compatibility with VMS.
C       Just ignore the message. Or Change %LOC to LOC.
C 
      program Dynamic_FRS

C  Declare the SQLCA and the SQLDA
      exec sql include sqlca
      exec sql include sqlda
      record /IISQLDA/ sqlda
      common /sqlda_are/ sqlda
      exec sql declare sel_stmt statement 
      exec sql declare ins_stmt statement 
      exec sql declare csr cursor for sel_stmt
      logical Describe_Form

      exec sql begin declare section
           character*40       dbname
           character*40       formname
           character*40       tabname
           character*1000     sel_buf
           character*1000     ins_buf 
           integer*4          err 
           character*1        ret 
      exec sql end declare section
      exec frs forms

C  Prompt for database name - will abort on errors
      exec sql whenever sqlerror stop
      exec frs prompt ('Database name: ', :dbname)
      exec sql connect :dbname
      exec sql whenever sqlerror call sqlprint

C 
C  Prompt for table name - later a Dynamic SQL SELECT statement
C  will be built from it.

C 
      exec frs prompt ('Table name: ', :tabname)

C
C  Prompt for form name. Check forms errors reported
C   through INQUIRE_FRS.

C 
      exec frs prompt ('Form name: ', :formname)
      exec frs message 'Loading form ...'
      exec frs forminit :formname
      exec frs inquire_frs frs (:err = ERRORNO)
      if (err .gt. 0) then
          exec frs message 'Could not load form. Exiting.'
          exec frs endforms
          exec sql disconnect
          stop
      end if

 

C  Commit any work done so far - access of forms catalogs
      exec sql commit

C  Describe the form and build the SQL statement strings
      if (.not. Describe_Form(formname, tabname, sel_buf, ins_buf))
     1 then
           exec frs message 'Could not describe form. Exiting.'
           exec frs endforms
           exec sql disconnect
           stop
      end if

C 
C  PREPARE the SELECT and INSERT statements that correspond to the 
C  menu items Browse and Insert. If the Save menu item is chosen
C  the statements are reprepared.
C 
      exec sql prepare sel_stmt from :sel_buf
      err = sqlcod
      exec sql prepare ins_stmt from :ins_buf
      if ((err .lt. 0) .or. (sqlcod .lt. 0)) then
       exec frs message 'Could not prepare SQL statements. Exiting'
          exec frs endforms
          exec sql disconnect
          stop
      end if

C
C  Display the form and interact with user, allowing browsing
C  and the inserting of new data.
C

      exec frs display :formname fill
      exec frs initialize
      exec frs activate menuitem 'Browse'
      exec frs begin

C
C  Retrieve data and display the first row on the form, 
C  allowing the user to browse through successive rows. If 
C  data types from the database table are not consistent 
C  with data descriptions obtained from the form, a
C  retrieval error will occur. Inform the user of this or other
C  errors.
C
C  Note that the data will return sorted by the first field
C  that was described, as the SELECT statement, sel_stmt,
C  included an ORDER BY clause.

C
           exec sql open csr

C  Fetch and display each row
           do while (sqlcod .eq. 0)

                exec sql fetch csr using descriptor :sqlda
                if (sqlcod .ne. 0) then
                     exec sql close csr
                    exec frs prompt noecho ('No more rows :', :ret)
                     exec frs clear field all
                     exec frs resume
                end if
                exec frs putform :formname using descriptor :sqlda
                exec frs inquire_frs frs (:err = ERRORNO)
                if (err .gt. 0) then
                     exec sql close csr
                     exec frs resume
                end if

 

C  Display data before prompting user with submenu
                exec frs redisplay
                exec frs submenu
                exec frs activate menuitem 'Next', frskey4
                exec frs begin

C  Continue with cursor loop
                     exec frs message 'Next row ...'
                     exec frs clear field all
                exec frs end
                exec frs activate menuitem 'End', frskey3
                exec frs begin
                     exec sql close csr
                     exec frs clear field all
                     exec frs resume
                exec frs end
           end do
      exec frs end
      exec frs activate menuitem 'Insert'
      exec frs begin
           exec frs getform :formname using descriptor :sqlda
           exec frs inquire_frs frs (:err = ERRORNO)
           if (err .gt. 0) then
                exec frs clear field all
                exec frs resume
           end if
           exec sql execute ins_stmt using descriptor :sqlda
           if ((sqlcod .lt. 0) .or. (sqlerr(3) .eq. 0)) then
               exec frs prompt noecho ('No rows inserted :', :ret)
           else
               exec frs prompt noecho ('One row inserted :', :ret)
           end if
      exec frs end
      exec frs activate menuitem 'Save'
      exec frs begin

C
C  COMMIT any changes and then re-PREPARE the SELECT and INSERT
C  statements as the COMMIT statements discards them.
C
           exec sql commit
           exec sql prepare sel_stmt from :sel_buf
           err = sqlcod
           exec sql prepare ins_stmt from :ins_buf
           if ((err .lt. 0) .or. (sqlcod .lt. 0)) then
                 exec frs prompt noecho
     1               ('Could not reprepare SQL statements :', :ret)
                 exec frs breakdisplay
           end if
      exec frs end
      exec frs activate menuitem 'Clear'
      exec frs begin
           exec frs clear field all
      exec frs end
      exec frs activate menuitem 'Quit', frskey2
      exec frs begin
           exec sql rollback
           exec frs breakdisplay
      exec frs end
      exec frs finalize
      exec frs endforms
      exec sql disconnect
      end        

 

C
C Procedure: Describe_Form
C Purpose:   Profile the specified form for name and data type
C            information.
C            Using the DESCRIBE FORM statement, the SQLDA is loaded
C            with field information from the form. This procedure
C            processes this information to allocate result storage,
C            point at storage C for dynamic FRS data retrieval and
C            assignment, and build C SQL statements strings for
C            subsequent dynamic SELECT and INSERT statements. For
C            example, assume the form (and table) 'emp' has the
C            following fields:
C
C             Field Name   Type       Nullable?
C             ----------   ----       ---------
C             name         char(10)   No
C             age          integer4   Yes
C             salary       money      Yes

C
C         Based on 'emp', this procedure will construct the SQLDA.
C         The procedure allocates variables from a result variable
C         pool (integers, floats and a large character string 
C         space). The SQLDATA and SQLIND fields are pointed at the 
C         addresses of the result variables in the pool. The 
C         following SQLDA is built:
C
C                    sqlvar(1)
C                           sqltype   = IISQ_CHA_TYPE
C                           sqllen    = 10
C                           sqldata = pointer into characters array
C                           sqlind    = null
C                           sqlname   = 'name'
C                    sqlvar(2)
C                           sqltype   = -IISQ_INT_TYPE
C                           sqllen    = 4
C                           sqldata   = address of integers(2)
C                           sqlind    = address of indicators(2)
C                           sqlname   = 'age'
C                    sqlvar(3)
C                           sqltype   = -IISQ_FLT_TYPE
C                           sqllen    = 8
C                           sqldata   = address of floats(3)
C                           sqlind    = address of indicators(3)
C                           sqlname   = 'salary'

C
C       This procedure also builds two dynamic SQL statements
C       strings. Note that the procedure should be extended to 
C       verify that the statement strings do fit into
C       the statement buffers (this was not done in this example).
C       The above example would construct the following 
C       statement strings:
C
C       'SELECT name, age, salary FROM emp ORDER BY name'
C       'INSERT INTO emp (name, age, salary) VALUES (?, ?, ?)'
C
C Parameters:
C         formname - Name of form to profile.
C         tabname - Name of database table.
C         sel_buf - Buffer to hold SELECT statement string.
C         ins_buf - Buffer to hold INSERT statement string.
C Returns:
C         TRUE/FALSE - Success/failure - will fail on error
C                       or upon finding a table field.
C
      logical function 
     1      Describe_Form (formname, tabname, sel_buf, ins_buf)

      character*(*) formname, tabname, sel_buf, ins_buf

 

C  Declare the SQLCA and the SQLDA
      exec sql include sqlca
      exec sql include sqlda
      record /IISQLDA/ sqlda
      common /sqlda_area/ sqlda

C  Global result data storage
      integer*4       integers(IISQ_MAX_COLS)
      real*8          reals(IISQ_MAX_COLS)
      integer*2       inds(IISQ_MAX_COLS)
      character*2500  characters 
      common /result_area/ integers, reals, inds, characters
      integer        char_cnt 
      integer        char_cur
      integer        i 
      integer        base_type 
      logical        nullable
      character*1000 names 
      integer        name_cnt 
      integer        name_cur 
      character*1000 marks 
      integer        mark_cnt
      integer*4      err
      character*     ret

C 
C Initialize the SQLDA and DESCRIBE the form. If we cannot fully
C describe the form (our SQLDA is too small) then report an error
C and return.
C 
      sqlda.sqln = IISQ_MAX_COLS
      exec frs describe form :formname all into :sqlda
      exec frs inquire_frs frs (:err = ERRORNO)
      if (err .gt. 0) then
           Describe_Form = .false.
           return
      end if
      if (sqlda.sqld .gt. sqlda.sqln) then
          exec frs prompt noecho ('SQLDA is too small for form :',
     1                             :ret)
          Describe_Form = .false.
          return
      else if (sqlda.sqld .eq. 0) then
           exec frs prompt noecho 
     1                  ('There are no fields in the form :', :ret)
           Describe_Form = .false.
           return
      end if

C 
C   For each field determine the size and type of the result data
C   area. This data area will be allocated out of the result
C   variable pool (integers, floats and characters) and will be
C   pointed at by SQLDATA and SQLIND.
C
C   If a table field type is returned then issue an error.
C 
C   Also, for each field add the field name to the 'names' buffer
C   and the SQL place holders '?' to the 'marks' buffer, which
C   will be used to build the final SELECT and INSERT statements.
C 

      char_cnt = 1
      name_cnt = 1
      mark_cnt = 1
      do 20, i = 1, sqlda.sqld

C  Find the base-type of the result (non-nullable).
           if (sqlda.sqlvar(i).sqltype .gt. 0) then
                base_type = sqlda.sqlvar(i).sqltype
                nullable = .false.
           else
                base_type = -sqlda.sqlvar(i).sqltype
                nullable = .true.
           end if

C 
C  Collapse all different types into one of INTEGER, REAL
C  or CHARACTER. Figure out where to point SQLDATA and
C  SQLIND - which member of the result variable pool is
C  compatible with the data.
C 
           if (base_type .eq. IISQ_INT_TYPE) then
                sqlda.sqlvar(i).sqltype  = IISQ_INT_TYPE
                sqlda.sqlvar(i).sqllen   = 4
                sqlda.sqlvar(i).sqldata  = %loc(integers(i))

           else if ((base_type .eq. IISQ_FLT_TYPE) .or.
     1          (base_type .eq. IISQ_DEC_TYPE) .or.
     2          (base_type .eq. IISQ_MNY_TYPE)) then    
                sqlda.sqlvar(i).sqltype = IISQ_FLT_TYPE
                sqlda.sqlvar(i).sqllen = 8
                sqlda.sqlvar(i).sqldata = %loc(reals(i))

           else if ((base_type .eq. IISQ_CHA_TYPE) .or.
     1          (base_type .eq. IISQ_VCH_TYPE) .or.
     2          (base_type .eq. IISQ_DTE_TYPE)) then

C 
C  Determine the length of the sub-string required from the
C  the large character array. If we have enough space left
C  then point at the start of the corresponding substring,
C  otherwise display an error and return.
C 
                     if (base_type .eq. IISQ_DTE_TYPE) then
                          char_cur = IISQ_DTE_LEN
                     else
                          char_cur = sqlda.sqlvar(i).sqllen 
                     end if
                    if ((char_cnt + char_cur) .gt. len(characters))
     1                    then
                          exec frs prompt noecho
     1                   ('Character pool buffer overflow :', :ret)
                          Describe_Form = .false.
                          return
                     end if

C 
C  Grab space out of the large character buffer and accumulate used
C  characters.
C 
                     sqlda.sqlvar(i).sqltype  = IISQ_CHA_TYPE
                     sqlda.sqlvar(i).sqllen   = char_cur
                     sqlda.sqlvar(i).sqldata  
     1                                = %loc(characters(char_cnt:))
                     char_cnt                 = char_cnt + char_cur
                else if (base_type .eq. IISQ_TBL_TYPE) then
                     exec frs prompt noecho 
     1                     ('Table field found in form :', :ret)
                     Describe_Form = .false.
                     return
                else
                     exec frs prompt noecho
     1                      ('Invalid field type :', :ret)
                     Describe_Form = .false.
                     return
                end if

C  Remember to save the null indicator
                if (nullable) then
                 sqlda.sqlvar(i).sqltype = -sqlda.sqlvar(i).sqltype
                     sqlda.sqlvar(i).sqlind = %loc(inds(i))
                else
                     sqlda.sqlvar(i).sqlind = 0
                end if

C 
C  Store field names and place holders (separated by commas)
C  for the SQL statements.
C 
                if (i .gt. 1) then
                     names(name_cnt:name_cnt) = ','
                     name_cnt = name_cnt + 1
                    marks(mark_cnt:mark_cnt) = ','
                    mark_cnt = mark_cnt + 1
               end if
               name_cur = sqlda.sqlvar(i).sqlname.sqlnamel
               names(name_cnt:name_cnt+name_cur) =
     1                sqlda.sqlvar(i).sqlname.sqlnamec(1:name_cur)
               name_cnt = name_cnt + name_cur
               marks(mark_cnt:mark_cnt) = '?'
               mark_cnt = mark_cnt + 1

20         continue

C 
C  Create final SELECT and INSERT statements. For the SELECT 
C  statement ORDER BY the first field.
C 
      name_cur = sqlda.sqlvar(1).sqlname.sqlnamel
      sel_buf = 'select ' // names(1:name_cnt-1) // ' from '
     1              // tabname // ' order by '
     2              // sqlda.sqlvar(1).sqlname.sqlnamec(1:name_cur)
      ins_buf = 'insert into ' // tabname // ' ('
     1      // names(1:name_cnt-1) // ') values ('
     2      // marks(1:mark_cnt-1) // ')'
      Describe_Form = .true.
      return
      end