Embedded QUEL Companion Guide > Embedded QUEL Companion Guide > Embedded QUEL for Fortran > Sample Applications > UNIX, VMS, Windows--An Interactive Database Browser Using Param Statements
Was this helpful?
UNIX, VMS, Windows--An Interactive Database Browser Using Param Statements
This application lets the user browse and update data in any table in any database. You should already have used VIFRED to create a default form based on the database table to be browsed. VIFRED builds a form whose fields have the same names and data types as the columns of the database table specified.
The program prompts the user for the name of the database, the table, and the form. In the Get_Form_Data procedure, it uses the formdata statement to find out the name, data type and length of each field on the form. It uses this information to dynamically build the elements for the param versions of the retrieve, append, putform and getform statements. These elements include the param target string, which describes the data to be processed, and the array of variable addresses, which informs the statement where to get or put the data. The type information the formdata statement collects includes the option of making a field nullable. If a field is nullable, the program builds a target string that specifies the use of a null indicator, and it sets the corresponding element of the array of variable addresses to point to a null indicator variable.
After the components of the param clause are built, the program displays the form. If the user selects the Browse menu item, the program uses a param version of the retrieve statement to obtain the data. For each row, the putform and redisplay statements exhibit this data to the user. A submenu allows the user to get the next row or to stop browsing. When the user selects the Insert menu item, the program uses the param versions of the getform and append statements to add a new row to the database.
The application runs in the UNIX, VMS, and Windows environments.
UNIX:
C
C   Procedure: main
C   Purpose:   Start up program and Ingres, prompting user
C              for names of form and table. Call Get_Form_Data() to
C              obtain profile of form. Then allow user to
C              interactively browse the database table and/or
C              APPEND new data. 

##  program main

##  declare forms
C   Global declarations 

C   Target string buffers for use in PARAM clauses of GETFORM,
C   PUTFORM, APPEND and RETRIEVE statements. Note that the APPEND
C   and PUTFORM statements have the same target string syntax.
C   Therefore in this application, because the form used 
C   corresponds exactly to the database table, these two statements
C   can use the same target string, 'putlst'.

C                  For APPEND and PUTFORM statements
##     character*1000    putlst
C                  For GETFORM statement
##     character*1000    getlst
C                  For RETRIEVE statement

##     character*1000    rtnlst

       integer MAXCOL, BUFSIZ
C                  DB maximum number of columns   
       parameter (MAXCOL = 127)
C                  Size of 'pool' of char strings 
       parameter (BUFSIZ = 3000)

C
C   An array of addresses of program data for use in the PARAM
C   clauses. This array will be initialized by the program to 
C   point to variables and null indicators.

C                Addresses of vars and inds
##         integer*4 varadr(MAXCOL*2)
C
C   Variables for holding data of type integer, float and 
C   character string. Note that to economize on memory usage,
C   character data is managed as segments on one large array,
C   'chvars'. Numeric variables and indicators are managed as an
C   array of structures. The addresses of these data areas
C   are assigned to the 'varadr' array, according to the type of 
C   the field/database column.

C              Pool for character data 
            character*(BUFSIZ) chvars

C             For integer data 
        integer*4         intv(MAXCOL)
C              For floating-point data 
        double precision  fltv(MAXCOL)
C              For null indicators 
        integer*2         indv(MAXCOL)

##      character*25 dbname, frmnam, tabnam
C              Catch database and forms errors
##      integer*4          inqerr
C              Catch error on database APPENDs
##      integer*4          numchg
C              Browse flag 
        logical           getnxt
C              Logical function (see below)   
        logical           GetFrm

        putlst = ' ' 
        etlst = ' ' 
        rtnlst = ' ' 
        chvars = ' '  

##      forms

##      prompt ('Database name: ', dbname)
C       '-E' flag tells Ingres not to quit on 
C       start-up errors 
##      ingres '-E' dbname
##      inquire_ingres (inqerr = ERRORNO) 
         f (inqerr .GT. 0) then
##          message 'Could not start Ingres. Exiting.'
##          endforms
##          exit 
            call exit 
        endif
C       Prompt for table and form names
##      prompt ('Table name: ', tabnam)
##      range of t IS tabnam
##      inquire_ingres (inqerr = ERRORNO) 
         if (inqerr .GT. 0) then
##           message 'Non-existent table. Exiting.'
##           endforms
##           exit 
             call exit 
        endif

##      prompt ('Form name: ', frmnam)

##      forminit frmnam
C       All forms errors are reported through INQUIRE_FRS
##      inquire_frs FRS (inqerr = ERRORNO) 
        if (inqerr .GT. 0) then
##          message 'Could not access form. Exiting.'
##          endforms
##          exit
            call exit
         endif
C
C        Get profile of form. Construct target lists and access
C        variables for use in queries to browse and update data.
C        if (.NOT. GetFrm (frmnam, putlst, getlst, rtnlst, varadr, 
    &              chvars, intv, fltv, indv)) then

##            message 'Could not profile form. Exiting.'
##            endforms
##            exit 
              call exit 
          endif
C
C      Display form and interact with user, allowing browsing and
C      appending of new data.

##     display frmnam fill
##     initialize
##     activate menuitem 'Browse'
##     {

C      Retrieve data and display first row on form, allowing user 
C      to browse through successive rows. If data types from table 
C      are not consistent with data descriptions obtained from  
C      user's form, a retrieval error will occur. Inform user of 
C      this or other errors.
C      Sort on first column. Note the use of 'ret_varN' to indicate
C      the column name to sort on.

##     retrieve (param(rtnlst, varadr)) 
##            sort by ret_var1
##     {                getnxt = .FALSE.
##            putform frmnam (param(putlst, varadr))

##            inquire_frs frs    (inqerr = ERRORNO) 
              if (inqerr .GT. 0) then
##                message 'Could not put data into form'
##                endretrieve 
              endif
C             Display data before prompting user with submenu
##            redisplay
##            submenu
##            activate menuitem 'Next', frskey4
##            {
##                  message 'Next row' 
                    getnxt = .TRUE.
##            }
##            activate menuitem 'End', frskey3
##            {
##                        endretrieve
##             }
##          }    /* End of RETRIEVE Loop */

##          inquire_ingres (inqerr = ERRORNO) 
            if (inqerr .GT. 0) then
##              message 'Could not retrieve data from database'
            else if (getnxt) then
C                Retrieve loop ended because of no more rows
##               message 'No more rows' 
            endif

##          sleep 2

C           Clear fields filled in submenu operations
##          clear field all
##     }

##     activate menuitem 'Insert'
##     {

##          getform frmnam (param(getlst, varadr))
##          inquire_frs frs (inqerr = ERRORNO) 
            if (inqerr .GT. 0) then
##               clear field all
##               resume
            endif

##          append to tabnam (param(putlst, varadr))

##          inquire_ingres (inqerr = ERRORNO, numchg = ROWCOUNT)   
       if ((inqerr .GT. 0) .OR. (numchg .EQ. 0)) then
##               message 'No rows appended because of error.'   
       else
##               message 'One row inserted' 
       endif
##     sleep 2
##     }

##     activate menuitem 'Clear'
##     {
##            clear field all
##     }

##     activate menuitem 'End', frskey3
##     {
##            breakdisplay
##     }

##     finalize
##     endforms
##     exit
##     end
C
C Procedure: GetFrm
C Purpose:   Get the name and data type of each field of a form
C            using the FORMDATA loop. From this information, build 
C            the target strings and array of variable addresses 
C            for use in the PARAM target list of database an  
C            and forms statements. For example, assume the
C            form has the following fields:
C
C             Field name      Type          Nullable?
C             ----------      ----          -------
C             name            character     No
C             age             integer       Yes
C             salary          money         Yes

C            Based on this form, this procedure will construct the
C            following target string for the PARAM clause of a 
C            PUTFORM statement:

C             'name = %c, age = %i4:%i2, salary = %f8:i2'

C            Note that the target strings for other statements have
C            differing syntax, depending on whether the
C            field/columnname or the user variable is the target of
C            the statement.

C            The other element of the PARAM clause, the 'varadr' 
C            array, would be constructed by this procedure as
C            follows:

C              varadr(1) = pointer into 'chvars' array
C              varadr(2) = address of intv(1)
C              varadr(3) = address of indv(1)
C              varadr(4) = address of fltv(2)
C              varadr(5) = address of indv(2)


##     logical function GetFrm (frmnam, putlst, getlst, rtnlst,
##   &                          varadr, chvars, intv, fltv, indv)

##     declare forms
##     character*(*)   frmnam
C               For APPEND and PUTFORM statements
##     character*(*)   putlst
C                For GETFORM statement
##     character*(*)   getlst
C                For RETRIEVE statement
##     character*(*)   rtnlst

C               DB maximum number of columns 
        integer*4      MAXCOL 
        parameter     (MAXCOL = 127)

C               Addresses of vars and inds

         integer*4      varadr(MAXCOL*2)
C                 Pool for character data 
         character*(*)  chvars

C                 For integer data 
         integer*4           intv(*)
C                 For floating-point data 
         double precision    fltv(*)
C                 For null indicators 
         integer*2           indv(*)
##       integer*4           inqerr
C                 Data type of field
##       integer*4           fldtyp
C                 Name of field
##       character*25        fldnam
C                 Length of field name 
         integer*4           fldlen
C                 Size of (character) field
##       integer*4           fldsiz
C                 Is field a table field?
##       integer*4           istbl
C                 Index into variable address array 
         integer*4           numadr
C                 Current field number 
         integer*4           fldcnt
C                 Return status 
         logical             rtnsts
C                 Length of character buffer 
         integer*4           chvlen

C        following 4 variables tell where to assign next character
C                 Index into putlst   
         integer*4           putcnt
C                 Index into getlst 
         integer*4           getcnt
C                 Index into rtnlst   
         integer*4           rtncnt
C                 Index into character pool 
         integer*4           chrptr
C        Data types of fields on form 
         integer*2 DATE, MONEY, CHAR, VARCHAR, INT, FLOAT, C, TEXT   
      parameter   (DATE       =        3, 
      &            MONEY      =        5, 
      &            CHAR       =        20, 
      &            VARCHAR    =        21, 
      &            INT        =        30, 
      &            FLOAT      =        31, 
      &            C          =        32, 
      &            TEXT       =        37 )

        rtnsts = .TRUE. 
        numadr = 1

        putcnt = 1 
        getcnt = 1 
        rtncnt = 1 
        chrptr = 1 
        fldcnt = 1

        chvlen = len(chvars)

##      formdata frmnam
##      {
C           Get data information and name of each field
##          inquire_frs field '' (fldtyp = DATATYPE, fldnam = NAME,
##                   fldsiz = LENGTH, istbl = TABLE)

C           Return on errors
##          inquire_frs frs (inqerr = ERRORNO) 
            if (inqerr .GT. 0) then 
               rtnsts = .FALSE.
##             enddata 
            endif
C
C          This application does not process table fields. However,
C          the TABLEDATA statement is available to profile table
C          fields.
C           if (istbl .EQ. 1) then
##              message 'Table field in form' 
##              sleep 2 
                rtnsts = .FALSE.
##              enddata 
            endif

C           More fields than allowable columns in database?   
            if (fldcnt .GT. MAXCOL) then
##             message 'Number of fields exceeds allowable
##                      database columns'
##             sleep 2 
               rtnsts = .FALSE.
##             enddata 
               endif

C            Separate target list items with commas 
               if (fldcnt .GT. 1) then 
                    putlst(putcnt:) = ',' 
                    putcnt = putcnt + 1

                    getlst(getcnt:) = ',' 
                    getcnt = getcnt + 1

                    rtnlst(rtncnt:) = ',' 
                    rtncnt = rtncnt + 1 
               endif
C            Calculate the length of fldnam without trailing spaces
             fldlen = len(fldnam) 
1000         continue 
             if ((fldlen .GT. 1) .AND. 
                  (fldnam(fldlen:fldlen) .EQ. ' ')) then 
                    fldlen = fldlen - 1 
                    goto 1000 
             end if

C            Field/column name is the target in 
C            PUTFORM/APPEND statements
             putlst(putcnt:) = fldnam 
             putcnt = putcnt + fldlen
C
C            Enter data type information in target list. Point
C            array of addresses into relevant data pool. 
C            Note that bytesting the absolute  
C            value of the data type value, the
C            program defers the question of nullable data to a 
C            later segment of the code, where it is handled in 
C            common for all types. (Recall that a negative data 
C            type indicates a nullable field.)

               if (abs(fldtyp) .EQ. INT) then 
                  putlst(putcnt:) = '=%i4' 
                  putcnt = putcnt + 4

                  getlst(getcnt:) = '%i4' 
                  getcnt = getcnt + 3

                  rtnlst(rtncnt:) = '%i4' 
                  rtncnt = rtncnt + 3

                  varadr(numadr) = IInum(intv(fldcnt)) 
                  numadr = numadr + 1

          else if ( (abs(fldtyp) .EQ. FLOAT) .OR. 
  &                 (abs(fldtyp) .EQ. MONEY) ) then

                  putlst(putcnt:) = '=%f8' 
                  putcnt = putcnt + 4

                  getlst(getcnt:) = '%f8' 
                  getcnt = getcnt + 3

                  rtnlst(rtncnt:) = '%f8' 
                  rtncnt = rtncnt + 3

                  varadr(numadr) = IInum(fltv(fldcnt)) 
                  numadr = numadr + 1

          else if ((abs(fldtyp) .EQ. C)            .OR. 
    &             (abs(fldtyp)  .EQ. CHAR)         .OR  .  
    &             (abs(fldtyp)  .EQ. TEXT)         .OR. 
    &             (abs(fldtyp)  .EQ. VARCHAR)      .OR. 
    &             (abs(fldtyp)  .EQ. DATE))       then

                  putlst(putcnt:) = '=%c' 
                  putcnt = putcnt + 3

                  getlst(getcnt:) = '%c' 
                  getcnt = getcnt + 2

                  rtnlst(rtncnt:) = '%c' 
                  rtncnt = rtncnt + 2
C
C                 Assign a segment of character buffer as space for
C                 data associated with this field. If assignment
C                 would cause overflow, give error and return.

                  if ( (chrptr + fldsiz) .GT. (chvlen) ) then
##                  message 'Character data fields will 
##                  cause overflow'
##                  sleep 2 
                    rtnsts = .FALSE.
##                  enddata 
                  endif

                  varadr(numadr) = 
                      IIstr(chvars(chrptr:chrptr+fldsiz-1))
                  numadr = numadr + 1
                  chrptr = chrptr + fldsiz

               else
##               message 'Field has unknown data type' 
                 rtnsts = .FALSE.
##               enddata 
               endif
C
C              If field is nullable, complete target lists and 
C              address assignments to allow for null data.

               if (fldtyp .LT. 0) then

                    putlst(putcnt:) = ':%i2' 
                    putcnt = putcnt + 4

                    getlst(getcnt:) = ':%i2' 
                    getcnt = getcnt + 4

                    rtnlst(rtncnt:) = ':%i2' 
                    rtncnt = rtncnt + 4

                    varadr(numadr) = IInum(indv(fldcnt)) 
                    numadr = numadr + 1

               endif
C              Ready for next field 
               fldcnt = fldcnt + 1

C              Field/column name is the object in 
C              GETFORM/RETRIEVE statements

               getlst(getcnt:) = '=' 
               getcnt = getcnt + 1 
               getlst(getcnt:) = fldnam 
               getcnt = getcnt + fldlen

               rtnlst(rtncnt:) = '=t.' 
               rtncnt = rtncnt + 3 
               rtnlst(rtncnt:) = fldnam 
               rtncnt = rtncnt + fldlen

##       }              /* End of FORMDATA loop */

         GetFrm = rtnsts 
         return
##       end  

VMS:

! Procedure: main
! Purpose:   Start up program and Ingres, prompting user 
!            for names of form and table. Call Get_Form_Data() to 
!            obtain profile of form. Then allow user to 
!            interactively browse the database table
!            and/or APPEND new data.
!

##    program main

##    declare forms

!     Global declarations 
!
!   Target string buffers for use in PARAM clauses of GETFORM, 
!   PUTFORM, APPEND and RETRIEVE statements. Note that the APPEND 
!   and PUTFORM statements have the same target string syntax.
!   Therefore in this application, because the form used
!   corresponds exactly to the database table, these two s
!   statements can use the same target string, 'put_target_list'.
!

##  character*1000 put_target_list  
!                               For APPEND and PUTFORM statements 
##  character*1000 get_target_list  ! For GETFORM statement 
##  character*1000 ret_target_list  ! For RETRIEVE statement

    integer maxcols, charbufsize
    parameter (maxcols = 127)       ! DB maximum number of columns
    parameter (charbufsize = 3000)  
!                         Size of 'pool' of char strings
!
!   An array of addresses of program data for use in the PARAM 
!   clauses. This array will be initialized by the program to
!   point to variables and null indicators.
!

##      integer*4 var_addresses(MAXCOLS*2) 
!                                    Addresses of vars and inds

!
!   Variables for holding data of type integer, float and 
!   character string. Note that to economize on memory usage, 
!   character data is managed as segments on one large array,
!   'char_vars'. Numeric variables and indicators are managed as 
!   an array of structures. The addresses of these data areas
!   are assigned to the 'var_addresses' array, according to the
!   type of the field/database column.
!
      character*(CHARBUFSIZE) char_vars ! Pool for character data

        structure /n_vars/
             integer*4 intv           ! For integer data
             double precision fltv    ! For floating-point data
             integer*2 indv           ! For null indicators
        end structure
        record /n_vars/ vars(MAXCOLS)

##      character*25  dbname, formname, tabname
##      integer*4     inq_error ! Catch database and forms errors
##      integer*4    num_updates ! Catch error on database APPENDs
        logical      want_next      ! Browse flag
        logical      Get_Form_Data  ! Logical function (see below)
        put_target_list = ' '
        get_target_list = ' '
        ret_target_list = ' '
        char_vars = ' '

##      forms

##      prompt ('Database name: ', dbname)

   ! '-E' flag tells Ingres not to quit on start-up errors
##      ingres '-E' dbname
##      inquire_ingres (inq_error = ERRORNO)
        if (inq_error .GT. 0) then
##          message 'Could not start Ingres. Exiting.'
##          endforms
##          exit
            call exit
        endif
        ! Prompt for table and form names
##      prompt ('Table name: ', tabname)
##      range of t IS tabname
##      inquire_ingres (inq_error = ERRORNO)
        if (inq_error .GT. 0) then
##          message 'Non-existent table. Exiting.'
##          endforms
##          exit
            call exit
        endif

##      prompt ('Form name: ', formname)
##      forminit formname

        ! All forms errors are reported through INQUIRE_FRS 
##      inquire_frs frs (inq_error = ERRORNO)
        if (inq_error .GT. 0) then
##          message 'Could not access form. Exiting.' 
##          endforms
##          exit
            call exit
        endif

        !
        ! Get profile of form. Construct target lists and access
        ! variables for use in queries to browse and update data.
        !   if (.NOT. Get_Form_Data (formname, put_target_list,
  1               get_target_list, ret_target_list, var_addresses,
  2               char_vars, vars)) then

##          message 'Could not profile form. Exiting.' 
##          endforms
##          exit
            call exit
      endif
      !
      ! Display form and interact with user, allowing browsing
      ! and appending of new data.
      !
##    display formname fill
##    initialize
##    activate menuitem 'Browse' 
##    {
        !
        ! Retrieve data and display first row on form, allowing 
        ! user to browse through successive rows. If data types 
        ! from table are not consistent with data descriptions
        ! obtained from user's form, a retrieval error will
        ! occur. Inform user of this or other errors.
        ! Sort on first column. Note the use of 'ret_varN' to
        ! indicate the column name to sort on.
        !

##      retrieve (param(ret_target_list, var_addresses)) 
##          sort by ret_var1
##      {
          want_next = .FALSE.
##        putform formname (param(put_target_list, var_addresses))

##          inquire_frs frs (inq_error = errorno)
            if (inq_error .GT. 0) then
##              message 'Could not put data into form'
##              endretrieve
            endif

            ! Display data before prompting user with submenu
##          redisplay
##          submenu
##          activate menuitem 'Next', frskey4
##          {
##              message 'Next row'
                want_next = .TRUE.
##          } 
##          activate menuitem 'End', frskey3
##          { 
##              endretrieve
##          }
##      }     /* End of RETRIEVE Loop */
##      inquire_ingres (inq_error = errorno)
        if (inq_error .GT. 0) then
##          message 'Could not retrieve data from database'

        else if (want_next) then
            ! Retrieve loop ended because of no more rows
##          message 'No more rows'
        endif

##      sleep 2

        ! Clear fields filled in submenu operations 
##      clear field all
##    }

##    activate menuitem 'Insert'
##    {

##        getform formname (param(get_target_list, var_addresses)) 
##        inquire_frs frs (inq_error = errorno)
          if (inq_error .GT. 0) then
##            clear field all
##            resume
          endif

##        append to tabname (param(put_target_list, 
##                var_addresses))

##        inquire_ingres (inq_error = errorno, 
##                num_updates = rowcount)
          if ((inq_error .GT. 0) .OR. (num_updates .EQ. 0)) then
##            message 'No rows appended because of error.'
          else 
##            message 'One row inserted'
          endif
##        sleep 2
##    }
##    activate menuitem 'Clear'
##    {
##        clear field all
##    }

##    activate menuitem 'End', frskey3
##    {
##         breakdisplay 
##    }

##    finalize
##    endforms
##    exit
##    end
!
! Procedure:   Get_Form_Data
! Purpose:     Get the name and data type of each field of a form 
!              using the FORMDATA loop. From this information,
!              build the target strings and array of variable
!              addresses for use in the PARAM target list of 
!              database and forms statements.
!              For example, assume the form has the
!              following fields:
!
!
!                 Field name        Type             Nullable?
!                 -------           ------           --------
!                 name              character        No
!                 age               integer          Yes
!                 salary            money            Yes
!
!              Based on this form, this procedure will construct 
!              the following target string for the PARAM clause 
!              of a PUTFORM statement:
!
!              'name = %c, age = %i4:%i2, salary = %f8:i2'
!
!              Note that the target strings for other statements 
!              have differing syntax, depending on whether the
!              field/column name or the user variable is the
!              target of the statement.
!
!              The other element of the PARAM clause, the
!              'var_addresses' array, would be constructed by this
!              procedure as follows:
!
!                  var_addresses(1) = 
!                               pointer into 'char_vars' array
!                  var_addresses(2) = address of vars(1).intv
!                  var_addresses(3) = address of vars(1).indv
!                  var_addresses(4) = address of vars(2).fltv
!                  var_addresses(5) = address of vars(2).indv
!
!
#          logical function Get_Form_Data (formname,
    1          put_target_list, get_target_list, ret_target_list,
    2          var_addresses, char_vars, vars)

##         declare forms
##         character*(*) formname

           character*(*) put_target_list                  
                        ! For APPEND and PUTFORM statements
           character*(*) get_target_list ! For GETFORM statement
           character*(*) ret_target_list ! For RETRIEVE statement

           integer*4 maxcols
           parameter (maxcols = 127)   
!                                 DB maximum number of columns

           integer*4 var_addresses(MAXCOLS*2) 
                                      ! Addresses of vars and inds
           character*(*) char_vars    ! Pool for character data

      structure /n_vars/
           integer*4 intv              ! For integer data
           double precision fltv       ! For floating-point data
           integer*2 indv              ! For null indicators
      end structure
      record /n_vars/ vars(MAXCOLS)
##        integer*4    inq_error
##        integer*4    fld_type      ! Data type of field
##        character*25 fld_name      ! Name of field
          integer*4    fld_name_len  ! Length of field name
##        integer*4    fld_length    ! Length of (character) field
##        integer*4    is_table      ! Is field a table field?
          character*15 loc_target    ! Temporary target description
          integer*4    addr_cnt ! Index into variable address array
          integer*4    fld_cnt       ! Current field number
          logical      ret_stat      ! Return status
          integer*4    char_vars_len ! Length of character buffer
          ! following 4 variables tell where to assign next 
          ! character
          integer*4    put_cnt       ! Index into put_target_list
          integer*4    get_cnt       ! Index into get_target_list
          integer*4    ret_cnt       ! Index into ret_target_list
          integer*4    char_ptr     ! Index into character pool

          ! Data types of fields on form
        integer*2 date, money, char, varchar, int, float, c, text
          parameter     (date          = 3,
    1                   money          = 5,
    2                   char           = 20,
    3                   varchar        = 21,
    4                   int            = 30,
    5                   float          = 31,
    6                   c              = 32,
    7                   text           = 37 )

          ret_stat   = .TRUE.
          addr_cnt   = 1

          put_cnt    = 1
          get_cnt    = 1
          ret_cnt    = 1
          char_ptr   = 1
          fld_cnt    = 1
          char_vars_len = len(char_vars)

##      formdata formname
##      {
          ! Get data information and name of each field
##    inquire_frs field '' (fld_type = datatype, fld_name = name,
##                          fld_length = length, is_table = table)
          ! Return on errors
##        inquire_frs frs (inq_error = errorno)
          if (inq_error .gt. 0) then
              ret_stat = .false.
##            enddata
          endif

          !
          ! This application does not process table fields.
          ! However, the TABLEDATA statement is available to
          ! profile table fields.
          !
          if (is_table .EQ. 1) then
##            message 'Table field in form'
##            sleep 2
              ret_stat = .FALSE.
##            enddata
          endif

          ! More fields than allowable columns in database?
          if (fld_cnt .GT. MAXCOLS) then
##            message 
##              'Number of fields exceeds allowable database 
##               columns'
##            sleep 2
              ret_stat = .FALSE.
##            enddata
          endif
          ! Separate target list items with commas
          if (fld_cnt .GT. 1) then
              put_target_list(put_cnt:) = ','
              put_cnt = put_cnt + 1

              get_target_list(get_cnt:) = ','
              get_cnt = get_cnt + 1

              ret_target_list(ret_cnt:) = ','
              ret_cnt = ret_cnt + 1
          endif

          ! Calculate the length of fld_name without trailing 
          ! spaces
          fld_name_len = len(fld_name)
          do while ((fld_name_len .GT. 1) .AND.
    1              (fld_name(fld_name_len:fld_name_len) .EQ. ' '))
              fld_name_len = fld_name_len - 1
          end do

          ! Field/column name is the target in PUTFORM/APPEND
          ! statements
          put_target_list(put_cnt:) = fld_name
          put_cnt = put_cnt + fld_name_len

          !
          ! Enter data type information in target list. Point 
          ! array of addresses into relevant data pool. Note that 
          ! by testing the absolute value of the data type value, 
          ! the program defers the question of nullable data to a 
          ! later segment of the code, where it is handled in 
          ! common for all types. (Recall that a negative data 
          ! type indicates a nullable field.)
          !
          if (abs(fld_type) .EQ. INT) then
              put_target_list(put_cnt:) = '=%i4'
              put_cnt = put_cnt + 4
    get_target_list(get_cnt:) = '%i4'
    get_cnt = get_cnt + 3

    ret_target_list(ret_cnt:) = '%i4'
    ret_cnt = ret_cnt + 3

    var_addresses(addr_cnt) = %loc(vars(fld_cnt).intv)
    addr_cnt = addr_cnt + 1

    else if ( (abs(fld_type) .eq. float) .or.
  1  (abs(fld_type) .eq. money) ) then

    put_target_list(put_cnt:) = '=%f8'
    put_cnt = put_cnt + 4

    get_target_list(get_cnt:) = '%f8'
    get_cnt = get_cnt + 3

    ret_target_list(ret_cnt:) = '%f8'
    ret_cnt = ret_cnt + 3

    var_addresses(addr_cnt) = %loc(vars(fld_cnt).fltv)
    addr_cnt = addr_cnt + 1

    else if ( (abs(fld_type)   .eq. c)                .or.
 1  (abs(fld_type)  .eq. char)             .or.
 2  (abs(fld_type)  .eq. text)             .or.
 3  (abs(fld_type)  .eq. varchar)          .or.
 4  (abs(fld_type)  .eq. date) )           then

    put_target_list(put_cnt:) = '=%c'
    put_cnt = put_cnt + 3

    get_target_list(get_cnt:) = '%c'
    get_cnt = get_cnt + 2

    ret_target_list(ret_cnt:) = '%c'
    ret_cnt = ret_cnt + 2

    !
    ! Assign a segment of character buffer as space for
    ! data associated with this field. If assignment would
    ! cause overflow, give error and return.
    !

    if ( (char_ptr + fld_length) .gt.
    1                         (char_vars_len) ) then
##  message 'Character data fields will cause overflow'
##  sleep 2
    ret_stat = .FALSE.
##  enddata
    endif
    var_addresses(addr_cnt) =
    1  IIdesc(char_vars(char_ptr:char_ptr+fld_length-1))
    addr_cnt = addr_cnt + 1
    char_ptr = char_ptr + fld_length

          else
##            message 'Field has unknown data type'
              ret_stat = .false.
##            enddata

          endif
          !
          ! If field is nullable, complete target lists and
          ! address assignments to allow for null data.
          !
          if (fld_type .LT. 0) then

              put_target_list(put_cnt:) = ':%i2'
              put_cnt = put_cnt + 4

              get_target_list(get_cnt:) = ':%i2'
              get_cnt = get_cnt + 4

              ret_target_list(ret_cnt:) = ':%i2'
              ret_cnt = ret_cnt + 4

              var_addresses(addr_cnt) = %loc(vars(fld_cnt).indv)
              addr_cnt = addr_cnt + 1

          endif

        ! Ready for next field
        fld_cnt = fld_cnt + 1

        ! Field/column name is the object in 
        ! getform/retrieve statements

          get_target_list(get_cnt:) = '='
          get_cnt = get_cnt + 1
          get_target_list(get_cnt:) = fld_name
          get_cnt = get_cnt + fld_name_len

          ret_target_list(ret_cnt:) = '=t.'
          ret_cnt = ret_cnt + 3
          ret_target_list(ret_cnt:) = fld_name
          ret_cnt = ret_cnt + fld_name_len

##      }            /* End of FORMDATA loop */
        Get_Form_Data = ret_stat
        return
##      end  

Windows:

! Procedure: main
! Purpose:   Start up program and Ingres, prompting user 
!            for names of form and table. Call Get_Form_Data() to 
!            obtain profile of form. Then allow user to 
!            interactively browse the database table
!            and/or APPEND new data.
!

##    program main

##    declare forms

!     Global declarations 
!
!   Target string buffers for use in PARAM clauses of GETFORM, 
!   PUTFORM, APPEND and RETRIEVE statements. Note that the APPEND 
!   and PUTFORM statements have the same target string syntax.
!   Therefore in this application, because the form used
!   corresponds exactly to the database table, these two s
!   statements can use the same target string, 'put_target_list'.
!

##  character*1000 put_target_list  
!                               For APPEND and PUTFORM statements 
##  character*1000 get_target_list  ! For GETFORM statement 
##  character*1000 ret_target_list  ! For RETRIEVE statement

        integer MAXCOLS, CHARBUFSIZE
        parameter (MAXCOLS = 127)       ! DB maximum number of columns
        parameter (CHARBUFSIZE = 3000)  
!                         Size of 'pool' of char strings
!
!   An array of addresses of program data for use in the PARAM 
!   clauses. This array will be initialized by the program to
!   point to variables and null indicators.
!

##      integer*4 var_addresses(MAXCOLS*2) 
!                                    Addresses of vars and inds

!
!   Variables for holding data of type integer, float and 
!   character string. Note that to economize on memory usage, 
!   character data is managed as segments on one large array,
!   'char_vars'. Numeric variables and indicators are managed as 
!   an array of structures. The addresses of these data areas
!   are assigned to the 'var_addresses' array, according to the
!   type of the field/database column.
!

      character*(CHARBUFSIZE) char_vars ! Pool for character data

        structure /n_vars/
             integer*4 intv           ! For integer data
             double precision fltv    ! For floating point data
             integer*2 indv           ! For null indicators
        end structure
        record /n_vars/ vars(MAXCOLS)

##      character*25  dbname, formname, tabname
##      integer*4     inq_error ! Catch database and forms errors
##      integer*4    num_updates ! Catch error on database APPENDs
        logical      want_next      ! Browse flag
        logical      Get_Form_Data  ! Logical function (see below)
        put_target_list = ' '
        get_target_list = ' '
        ret_target_list = ' '
        char_vars = ' '

##      forms
##      prompt ('Database name: ', dbname)

        ! '-E' flag tells Ingres not to quit on start-up errors
##      ingres '-E' dbname
##      inquire_ingres (inq_error = ERRORNO)
        if (inq_error .GT. 0) then
##          message 'Could not start Ingres. Exiting.'
##          endforms
##          exit
            call exit
        endif

        ! Prompt for table and form names
##      prompt ('Table name: ', tabname)
##      range of t IS tabname
##      inquire_ingres (inq_error = ERRORNO)
        if (inq_error .GT. 0) then
##          message 'Non-existent table. Exiting.'
##          endforms
##          exit
            call exit
        endif
##      prompt ('Form name: ', formname)
##      forminit formname

        ! All forms errors are reported through INQUIRE_FRS 
##      inquire_frs frs (inq_error = ERRORNO)
        if (inq_error .GT. 0) then
##          message 'Could not access form. Exiting.' 
##          endforms
##          exit
            call exit
        endif

        !
        ! Get profile of form. Construct target lists and access
        ! variables for use in queries to browse and update data.
        if (.NOT. Get_Form_Data (formname, put_target_list,
     1               get_target_list, ret_target_list, var_addresses,
     2               char_vars, vars)) then

##          message 'Could not profile form. Exiting.' 
##          endforms
##          exit
            call exit
      endif
      !
      ! Display form and interact with user, allowing browsing
      ! and appending of new data.
      !
##    display formname fill
##    initialize
##    activate menuitem 'Browse' 
##    {
        !
        ! Retrieve data and display first row on form, allowing 
        ! user to browse through successive rows. If data types 
        ! from table are not consistent with data descriptions
        ! obtained from user's form, a retrieval error will
        ! occur. Inform user of this or other errors.
        ! Sort on first column. Note the use of 'ret_varN' to
        ! indicate the column name to sort on.
        !

##      retrieve (param(ret_target_list, var_addresses)) 
##          sort by ret_var1
##      {
          want_next = .FALSE.
##        putform formname (param(put_target_list, var_addresses))

##          inquire_frs frs (inq_error = errorno)
            if (inq_error .GT. 0) then
##              message 'Could not put data into form'
##              endretrieve
            endif

            ! Display data before prompting user with submenu
##          redisplay
##          submenu
##          activate menuitem 'Next', frskey4
##          {
##              message 'Next row'
                want_next = .TRUE.
##          } 
##          activate menuitem 'End', frskey3
##          { 
##              endretrieve
##          }
##      }     /* End of RETRIEVE Loop */
##      inquire_ingres (inq_error = errorno)
        if (inq_error .GT. 0) then
##          message 'Could not retrieve data from database'

        else if (want_next) then
            ! Retrieve loop ended because of no more rows
##          message 'No more rows'
        endif

##      sleep 2

        ! Clear fields filled in submenu operations 
##      clear field all
##    }
##    activate menuitem 'Insert'
##    {

##        getform formname (param(get_target_list, var_addresses)) 
##        inquire_frs frs (inq_error = errorno)
          if (inq_error .GT. 0) then
##            clear field all
##            resume
          endif

##        append to tabname (param(put_target_list, 
##                var_addresses))

##        inquire_ingres (inq_error = errorno, 
##                num_updates = rowcount)
          if ((inq_error .GT. 0) .OR. (num_updates .EQ. 0)) then
##            message 'No rows appended because of error.'
          else 
##            message 'One row inserted'
          endif
##        sleep 2
##    }
##    activate menuitem 'Clear'
##    {
##        clear field all
##    }

##    activate menuitem 'End', frskey3
##    {
##         breakdisplay 
##    }

##    finalize
##    endforms
##    exit
##    end
!
! Procedure:   Get_Form_Data
! Purpose:     Get the name and data type of each field of a form 
!              using the FORMDATA loop. From this information,
!              build the target strings and array of variable
!              addresses for use in the PARAM target list of 
!              database and forms statements.
!              For example, assume the form has the
!              following fields:
!
!
!                 Field name        Type             Nullable?
!                 -------           ------           --------
!                 name              character        No
!                 age               integer          Yes
!                 salary            money            Yes
!
!              Based on this form, this procedure will construct 
!              the following target string for the PARAM clause 
!              of a PUTFORM statement:
!
!              'name = %c, age = %i4:%i2, salary = %f8:i2'
!
!              Note that the target strings for other statements 
!              have differing syntax, depending on whether the
!              field/column name or the user variable is the
!              target of the statement.
!
!              The other element of the PARAM clause, the
!              'var_addresses' array, would be constructed by this
!              procedure as follows:
!
!                  var_addresses(1) = 
!                               pointer into 'char_vars' array
!                  var_addresses(2) = address of vars(1).intv
!                  var_addresses(3) = address of vars(1).indv
!                  var_addresses(4) = address of vars(2).fltv
!                  var_addresses(5) = address of vars(2).indv
!
!
##          logical function Get_Form_Data (formname,
     1          put_target_list, get_target_list, ret_target_list,
     2          var_addresses, char_vars, vars)

##         declare forms
##         character*(*) formname

           character*(*) put_target_list                  
                        ! For APPEND and PUTFORM statements
           character*(*) get_target_list ! For GETFORM statement
           character*(*) ret_target_list ! For RETRIEVE statement

           integer*4 MAXCOLS
           parameter (MAXCOLS = 127)   
!                                 DB maximum number of columns

           integer*4 var_addresses(MAXCOLS*2) 
                                      ! Addresses of vars and inds
           character*(*) char_vars    ! Pool for character data

      structure /n_vars/
           integer*4 intv              ! For integer data
           double precision fltv       ! For floating point data
           integer*2 indv              ! For null indicators
      end structure
      record /n_vars/ vars(MAXCOLS)
##        integer*4    inq_error
##        integer*4    fld_type      ! Data type of field
##        character*25 fld_name      ! Name of field
          integer*4    fld_name_len  ! Length of field name
##        integer*4    fld_length    ! Length of (character) field
##        integer*4    is_table      ! Is field a table field?
          character*15 loc_target    ! Temporary target description
          integer*4    addr_cnt ! Index into variable address array
          integer*4    fld_cnt       ! Current field number
          logical      ret_stat      ! Return status
          integer*4    char_vars_len ! Length of character buffer
          ! following 4 variables tell where to assign next 
          ! character
          integer*4    put_cnt       ! Index into put_target_list
          integer*4    get_cnt       ! Index into get_target_list
          integer*4    ret_cnt       ! Index into ret_target_list
          integer*4    char_ptr     ! Index into character pool

          ! Data types of fields on form
        integer*2 date, money, char, varchar, int, float, c, text
          parameter     (date          = 3,
     1                   money          = 5,
     2                   char           = 20,
     3                   varchar        = 21,
     4                   int            = 30,
     5                   float          = 31,
     6                   c              = 32,
     7                   text           = 37 )

          ret_stat   = .TRUE.
          addr_cnt   = 1

          put_cnt    = 1
          get_cnt    = 1
          ret_cnt    = 1
          char_ptr   = 1
          fld_cnt    = 1
          char_vars_len = LEN(char_vars)
##      formdata formname
##      {
          ! Get data information and name of each field
##    inquire_frs field '' (fld_type = datatype, fld_name = name,
##                          fld_length = length, is_table = table)

          ! Return on errors
##        inquire_frs frs (inq_error = errorno)
          if (inq_error .gt. 0) then
              ret_stat = .false.
##            enddata
          endif

          !
          ! This application does not process table fields.
          ! However, the TABLEDATA statement is available to
          ! profile table fields.
          !
          if (is_table .EQ. 1) then
##            message 'Table field in form'
##            sleep 2
              ret_stat = .FALSE.
##            enddata
          endif

          ! More fields than allowable columns in database?
          if (fld_cnt .GT. MAXCOLS) then
##            message 
##              'Number of fields exceeds allowable database columns'
##            sleep 2
              ret_stat = .FALSE.
##            enddata
          endif
          ! Separate target list items with commas
          if (fld_cnt .GT. 1) then
              put_target_list(put_cnt:) = ','
              put_cnt = put_cnt + 1

              get_target_list(get_cnt:) = ','
              get_cnt = get_cnt + 1

              ret_target_list(ret_cnt:) = ','
              ret_cnt = ret_cnt + 1
          endif

          ! Calculate the length of fld_name without trailing 
          ! spaces
          fld_name_len = LEN(fld_name)
          do while ((fld_name_len .GT. 1) .AND.
     1              (fld_name(fld_name_len:fld_name_len) .EQ. ' '))
              fld_name_len = fld_name_len - 1
          end do

          ! Field/column name is the target in PUTFORM/APPEND
          ! statements
          put_target_list(put_cnt:) = fld_name
          put_cnt = put_cnt + fld_name_len
          !
          ! Enter data type information in target list. Point 
          ! array of addresses into relevant data pool. Note that 
          ! by testing the absolute value of the data type value, 
          ! the program defers the question of nullable data to a 
          ! later segment of the code, where it is handled in 
          ! common for all types. (Recall that a negative data 
          ! type indicates a nullable field.)
          !
          if (abs(fld_type) .EQ. INT) then
              put_target_list(put_cnt:) = '=%i4'
              put_cnt = put_cnt + 4

        get_target_list(get_cnt:) = '%i4'
        get_cnt = get_cnt + 3

        ret_target_list(ret_cnt:) = '%i4'
        ret_cnt = ret_cnt + 3

        var_addresses(addr_cnt) = %loc(vars(fld_cnt).intv)
        addr_cnt = addr_cnt + 1

        else if ( (abs(fld_type) .eq. float) .or.
     1  (abs(fld_type) .eq. money) ) then

        put_target_list(put_cnt:) = '=%f8'
        put_cnt = put_cnt + 4

        get_target_list(get_cnt:) = '%f8'
        get_cnt = get_cnt + 3

        ret_target_list(ret_cnt:) = '%f8'
        ret_cnt = ret_cnt + 3

        var_addresses(addr_cnt) = %loc(vars(fld_cnt).fltv)
        addr_cnt = addr_cnt + 1

        else if ( (abs(fld_type)   .eq. c)                .or.
     1  (abs(fld_type)  .eq. char)             .or.
     2  (abs(fld_type)  .eq. text)             .or.
     3  (abs(fld_type)  .eq. varchar)          .or.
     4  (abs(fld_type)  .eq. date) )           then

        put_target_list(put_cnt:) = '=%c'
        put_cnt = put_cnt + 3

        get_target_list(get_cnt:) = '%c'
        get_cnt = get_cnt + 2

        ret_target_list(ret_cnt:) = '%c'
        ret_cnt = ret_cnt + 2
    !
    ! Assign a segment of character buffer as space for
    ! data associated with this field. If assignment would
    ! cause overflow, give error and return.
    !

        if ( (char_ptr + fld_length) .gt.
     1                         (char_vars_len) ) then
##  message 'Character data fields will cause overflow'
##  sleep 2
        ret_stat = .FALSE.
##  enddata
        endif
        var_addresses(addr_cnt) =
     1  IIdesc(char_vars(char_ptr:char_ptr+fld_length-1))
        addr_cnt = addr_cnt + 1
        char_ptr = char_ptr + fld_length

          else
##            message 'Field has unknown data type'
              ret_stat = .false.
##            enddata

          endif
          !
          ! If field is nullable, complete target lists and
          ! address assignments to allow for null data.
          !
          if (fld_type .LT. 0) then

              put_target_list(put_cnt:) = ':%i2'
              put_cnt = put_cnt + 4

              get_target_list(get_cnt:) = ':%i2'
              get_cnt = get_cnt + 4

              ret_target_list(ret_cnt:) = ':%i2'
              ret_cnt = ret_cnt + 4

              var_addresses(addr_cnt) = %loc(vars(fld_cnt).indv)
              addr_cnt = addr_cnt + 1

          endif
        ! Ready for next field
        fld_cnt = fld_cnt + 1

        ! Field/column name is the object in 
        ! getform/retrieve statements

          get_target_list(get_cnt:) = '='
          get_cnt = get_cnt + 1
          get_target_list(get_cnt:) = fld_name
          get_cnt = get_cnt + fld_name_len

          ret_target_list(ret_cnt:) = '=t.'
          ret_cnt = ret_cnt + 3
          ret_target_list(ret_cnt:) = fld_name
          ret_cnt = ret_cnt + fld_name_len

##      }            /* End of FORMDATA loop */
        Get_Form_Data = ret_stat
        return
##      end  
 
Last modified date: 06/10/2024