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
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
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
C Addresses of vars and inds
## integer*4 varadr(MAXCOL*2)
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
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
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
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
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 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
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 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 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.
C
## display frmnam fill
## initialize
## activate menuitem 'Browse'
## {
C
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.
C
## 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 form and interact with user, allowing browsing and
C appending of new data.
C
## display frmnam fill
## initialize
## activate menuitem 'Browse'
## {
C
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.
C
## 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
## 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
C Based on this form, this procedure will construct the
C following target string for the PARAM clause of a
C PUTFORM statement:
C
C 'name = %c, age = %i4:%i2, salary = %f8:i2'
C
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
C The other element of the PARAM clause, the 'varadr'
C array, would be constructed by this procedure as
C follows:
C
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)
C
C
## logical function GetFrm (frmnam, putlst, getlst, rtnlst,
## & varadr, chvars, intv, fltv, indv)
## declare forms
## character*(*) frmnam
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
C Based on this form, this procedure will construct the
C following target string for the PARAM clause of a
C PUTFORM statement:
C
C 'name = %c, age = %i4:%i2, salary = %f8:i2'
C
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
C The other element of the PARAM clause, the 'varadr'
C array, would be constructed by this procedure as
C follows:
C
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)
C
C
## 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(*)
## 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 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
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 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
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.)
C
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 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.)
C
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.
C
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 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.
C
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.
C
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 If field is nullable, complete target lists and
C address assignments to allow for null data.
C
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
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
! 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.
!
! 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
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
## 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 */
! 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
## }
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
## {
## 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
!
!
! 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)
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)
## 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
## 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
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
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
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
! 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
! 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
! 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
! '-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
## 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 */
! 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
## }
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
## }
## {
## 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
## {
## 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
!
!
! 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)
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)
## 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
## {
! 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
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
! 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
! 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
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
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: 08/28/2024