C Program: SQL_Monitor
C Purpose: Main entry of SQL Monitor application. Prompt for
C          database name and connect to the database. Run the 
C          monitor and disconnect from the database. Before
C          disconnecting roll back any pending updates.

C

C   UNIX compiler will generate - "Warning: %LOC function
C         treated as LOC."
C         This is for compatibility with VMS. Just ignore the
C         message or change %LOC to LOC.

C
      program SQL_Monitor
      exec sql include sqlca
      exec sql begin declare section
           character*50   dbname
      exec sql end declare section

C    Prompt for database name.
      write   (*, 50)
50    format (' SQL Database: ', $)
      read (*, 51, err = 59, end = 59) dbname
51    format (A)

      print *, ' -- SQL Terminal Monitor --'

C     Treat connection errors as fatal.
      exec sql whenever sqlerror stop
      exec sql connect :dbname
      call Run_Monitor()
      exec sql whenever sqlerror continue
      print *, 'SQL: Exiting monitor program.'
      exec sql rollback
      exec sql disconnect
59    end

 

C
C Subroutine:Run_Monitor
C Purpose:   Run the SQL monitor. Initialize the global SQLDA with
C            the number of SQLVAR elements. Loop while prompting 
C            the user for input; if end-of-file is detected then
C            return to the main program.
C
C            If the statement is not a SELECT statement then 
C            EXECUTE it, otherwise open a cursor a process a 
C            dynamic SELECT statement (using Execute_Select).
C
      subroutine Run_Monitor

C     Declare the SQLCA and the SQLDA structure definition
      exec sql include sqlca
      exec sql include sqlda
      exec sql begin declare section
          character*1000  stmt_buf
      exec sql end declare section
      record /IISQLDA/ sqlda
      common /sqlda_area/ sqlda
      integer  stmt_num
      integer      rows
      logical      Read_Stmt
      integer      Execute_Select
      exec sql declare stmt statement

C     Initialize the SQLDA
      sqlda.sqln = IISQ_MAX_COLS

C     Now we are set for input
      stmt_num = 0
      do while (.TRUE.)

           stmt_num = stmt_num + 1

C
C     Prompt and read the next statement. If Read_Stmt
C     returns FALSE then end-of-file was detected.
C
           if (.not. Read_Stmt(stmt_num, stmt_buf)) return

C     Handle database errors.
           exec sql whenever sqlerror goto 62

C
C     Prepare and describe the statement. If the statement is not
C     a SELECT then EXECUTE it, otherwise inspect the contents of
C     the SQLDA and call Execute_Select.
C
           exec sql prepare stmt from :stmt_buf
           exec sql describe stmt into :sqlda

C     If SQLD = 0 then this is not a SELECT.
           if (sqlda.sqld .eq. 0) then
                exec sql execute stmt
                rows = sqlerr(3)

           else

C        Are there enough result variables
                if (sqlda.sqld .le. sqlda.sqln) then
                     rows = Execute_Select()
                else
                     write(*, 60) sqlda.sqld, sqlda.sqln
60                   format (' SQL Error: SQLDA requires ', I3,
     1                        ' variables, but has only ', I3 '.')
                     rows = 0
                end if
           end if

C     Print number of rows processed.
           write (*, 61) rows
61         format (' [', I6, ' row(s)]')

           exec sql whenever sqlerror continue
C    If we got here because of an error then print the error 
C    message.
62         if (sqlcod .lt. 0) call Print_Error()
      end do 
      return
      end

C
C Function: Execute_Select
C Purpose:  In a dynamic SELECT statement. The SQLDA has already 
C           been described, so print the column header (names), 
C           open a cursor and retrieve and print the results. 
C           Accumulate the number of rows processed.
C Parameters:
C            None
C Returns:
C            Number of rows processed.
C
      integer function Execute_Select()
      exec sql include sqlca
      exec sql include sqlda
      record /IISQLDA/ sqlda
      common /sqlda_area/ sqlda
      integerrows
      logical Print_Header
      exec sql declare csr cursor for stmt

C  
C  Print result column names, set up the result types and
C  variables. Print_Header returns FALSE if the dynamic 
C  set-up failed.
C  
      if (.not. Print_Header()) then
           Execute_Select = 0
           return
      end if
      exec sql whenever sqlerror goto 70

C  Open the dynamic cursor.
      exec sql open csr for readonly

C  Fetch and print each row.
      rows = 0
      do while (sqlcod .eq. 0)

           exec sql fetch csr using descriptor :sqlda
           if (sqlcod .eq. 0) then
                rows = rows + 1
                call Print_Row()
           end if
      end do

C   If we got here because of an error then print the error 
C   message.
70    if (sqlcod .lt. 0) call Print_Error()
      exec sql whenever sqlerror continue
      exec sql close csr
      Execute_Select = rows
      return
      end

C
C Function: Print_Header
C Purpose:  A statement has just been described so set up the SQLDA
C           for result processing. Print all the column names and
C           allocate result variables for retrieving data. The
C           result variables are chosen out of a pool of variables 
C           (integers, floats and a large character string space). 
C           The SQLDATA and SQLIND fields are pointed at the 
C           addresses of the result variables.
C Returns:
C           TRUE if successfully set up the SQLDA for 
C           result variables,
C           FALSE if an error occurred.
C
      logical function Print_Header ()
      exec sql include sqlda
      record /IISQLDA/ sqlda
      common /sqlda_area/ sqlda

C  User defined handler for large objects
      external UsrDataHandler
      integer  UsrDataHandler

C  Limit the size of a large object
C  If you increase BLOB_MAX than increase hdlarg.argstr 
C  and 'segbuf'
       parameter (BLOB_MAX = 50)

       record /IISQLHDLR/ datahdlr(IISQ_MAX_COLS)

C     Global result data storage
      structure      /hdlr_arg/
          character*50 argstr
          integer arglen
      end structure
      record /hdlr_arg/ hdlarg(IISQ_MAX_COLS)

      integer*4         integers(IISQ_MAX_COLS)
      real*8            reals(IISQ_MAX_COLS)
      integer*2         inds(IISQ_MAX_COLS)
      character*2500    characters
      character*3000    disp_results
      common /result_area/ integers, reals, inds, characters,
     1      disp_results
      integer          cl
      integer          clc
      integer          dl
      character*2000   names
      integer          nl
      integer          nlc
      integer          i
      integer          base_type
      logical          is_null

C
C Add the name and number of each column into a column name buffer.
C Display this buffer as a header when done with all the columns.
C While processing each column determine the type of the column
C and to where SQLDATA must point in order to retrieve compatible
C results.
C
      cl = 1
      nl = 1
      dl = 0
      do 85, i = 1, sqlda.sqld            
C  
C  Fill up the names buffer. If it overflows print an error and
C  return that we failed.
C  
      if (nl .gt. (len(names) - 40)) then
          print *, 'SQL Error: Result column name overflow.'
          Print_Header = .false.
          return
      end if

C
C  Store column title in the form "[column #] column_name "
C  For example, the employee table may look like:
C     [1] name [ 2] age [ 3] salary [ 4] dept
C
      write (names(nl:),80)i
80    format ('[', I3, '] ')
      nl = nl + 6
      nlc = sqlda.sqlvar(i).sqlname.sqlnamel
      names(nl:nl+nlc) = sqlda.sqlvar(i).sqlname.sqlnamec(1:nlc)
      nl = nl + nlc
      names(nl:nl) = ' '
      nl = nl + 1

C
C  At this point we've stored away the column name. Now we
C  process the column for type and length information. Use the
C  global numeric array and the large character buffer from which
C  pieces can be allocated.
C
C  Also accumulate the length of the display buffer that we will
C  need later to print the results - they will all be converted
C  into character data in the display buffer. Make sure that
C  the default field widths of the different types will fit into
C  the buffer 'disp_results'. For example, the display buffer for
C  a single row of the employee table may look like:
C  [ 1] mark [ 2] 36 [ 3] 52000.0 [ 4] eng
C
      dl = dl + 7

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

C
C  Collapse all different types into one of INTEGER, REAL
C  or CHARACTER. Accumulate the number of characters required
C  from the display buffer (use default format lengths).
C
      if (base_type .eq. IISQ_INT_TYPE) then
         sqlda.sqlvar(i).sqltype = IISQ_INT_TYPE
         sqlda.sqlvar(i).sqllen = 4
         sqlda.sqlvar(i).sqldata = %loc(integers(i))
         dl = dl + 12
      else if ((base_type .eq. IISQ_FLT_TYPE) .or.
     1          (base_type .eq. IISQ_DEC_TYPE)    .or. 
     2          (base_type .eq. IISQ_MNY_TYPE)) then
         sqlda.sqlvar(i).sqltype = IISQ_FLT_TYPE
         sqlda.sqlvar(i).sqllen = 8
         sqlda.sqlvar(i).sqldata = %loc(reals(i))
         dl = dl + 25
      else if ((base_type .eq. IISQ_CHA_TYPE) .or.
     1          (base_type .eq. IISQ_VCH_TYPE) .or.
     2          (base_type .eq. IISQ_DTE_TYPE)) then

C
C Determine the length of the sub-string required from the
C the large character array. If we have enough space left
C then point at the start of the corresponding substring,
C otherwise print an error and return.
C
           if (base_type .eq. IISQ_DTE_TYPE) then
              clc = 25
           else
              clc = sqlda.sqlvar(i).sqllen 
           end if
           if ((cl + clc) .gt. len(characters)) then
                write (*, 81) cl+clc
81           format (' SQL Error: Character result data overflow. '
     1                   'Need ', I4, ' bytes.')
                Print_Header = .false.
                return
           end if 

C       Grab space out of the large character buffer
           sqlda.sqlvar(i).sqltype = IISQ_CHA_TYPE
           sqlda.sqlvar(i).sqllen = clc
           sqlda.sqlvar(i).sqldata = %loc(characters(cl:))
           cl = cl + clc
           dl = dl + clc
      else if (base_type .eq. IISQ_LVCH_TYPE) then
C
C Long varchar, so use datahandler. Use Blob Max to limit the
C length of the Blob sub-string returned/displayed.
C       
           sqlda.sqlvar(i).sqltype = IISQ_HDLR_TYPE
           sqlda.sqlvar(i).sqllen = BLOB_MAX
           sqlda.sqlvar(i).sqldata = %loc(datahdlr(i))

           datahdlr(i).sqlhdlr = %loc(UserDataHandler)
           datahdlr(i).sqlarg = %loc(hdlrag(i))
        
           hdlarg(i).arglen = BLOB_MAX

           d1 = d1 + BLOB_MAX
      end if

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

85    continue

C
C  Print all the saved column names. This loop does not use any
C  special formats, but just breaks the line at column 75.
C
      nl = nl - 1
      do 88 i = 1, nl , 75
           write (*, 87) names(i:min(i+74,nl))
87         format (' ', A)
88    continue
      print *, '--------------------------------'

C
C   Confirm that the character representation of the results 
C   will fit inside the display buffer.
C
      if (dl .gt. len(disp_results)) then
           write (*, 81) dl
89         format (' SQL Error: Result display buffer overflow. '
     1              'Need ', I4, ' bytes.')
           Print_Header = .false.
           return
      end if
      Print_Header = .true.
      return
      end
C
C Procedure:Print_Row
C Purpose:  For each element inside the SQLDA, print the value. 
C           Print its column number too in order to identify it 
C           with a column name printed earlier in Print_Header. If 
C           the value is NULL print "N/A".
C Parameters:
C           None
C
      subroutine Print_Row      
      exec sql include sqlda
      record /IISQLDA/ sqlda
      common /sqlda_area/ sqlda

C  Global result data storage
      structure     /hdlr_arg/
         character*50   argstr
         integer        arglen 
      end structure
      record /hdlr_arg/ hdlarg(IISQ_MAX_COLS)

      integer*4     integers(IISQ_MAX_COLS)
      real*8        reals(IISQ_MAX_COLS)
      integer*2     inds(IISQ_MAX_COLS)
      character*2500     characters
      character*3000     disp_results
      common /result_area/ integers, reals, inds, characters, 
     1    disp_results, hdlarg
      integer      cl
      integer      clc
      integer      dl
      integer      i
      integer      base_type
      logical      is_null

C
C  For each column, print the column number and the data.
C  NULL columns print as "N/A". The printing is done by
C  encoding the complete row into a display buffer (that is
C  already guaranteed to be able to contain the whole row),
C  and then displaying the data at the end of the row.
C
      cl = 1
      dl = 1
      do 95, i = 1, sqlda.sqld

C Store result column number in the form "[ # ]"
           write(disp_results(dl:),90)i
90         format ('[', I3, '] ')
           dl = dl + 6

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

C
C Collapse different types into INTEGER, REAL or CHARACTER.
C If the data is NULL then just print "N/A".
C 
           if (is_null .and. (inds(i) .eq. -1)) then
                disp_results(dl:dl+2) = 'N/A'
                dl = dl + 3
           else if (base_type .eq. IISQ_INT_TYPE) then
                write(disp_results(dl:),91)i
91              format (I)
                dl = dl + 12
           else if (base_type .eq. IISQ_FLT_TYPE) then
                write(disp_results(dl:),92)i
92              format (G)
                dl = dl + 25
           else if (base_type .eq. IISQ_CHA_TYPE) then

C    Use the characters out of the large character buffer
                clc = sqlda.sqlvar(i).sqllen 
                disp_results(dl:dl+clc-1) = characters(cl:)
                dl = dl + clc
                cl = cl + clc
           else if (base_type .eq. IISQ_HDLR_TYPE) then
C  Use the argstr out of the handler structure buffer
                clc = sqlda.sqlvar(i).sqllen
                disp_results(d1:d1+clc-1) = hdlarg(i).argstr
                dl = dl + clc
           end if
           disp_results(dl:dl) = ' '
           dl = dl + 1

95    continue
      !
      ! Print the result data. This loop does not use any special
      ! formats, but just breaks the line at column 75.
      !
      dl = dl - 1
      do 98 i = 1, dl , 75
           write (*, 97) disp_results(i:min(i+74,dl))
97         format (' ', A)
98    continue
      return
      end

C
C Subroutine: Print_Error
C Purpose:    SQLCA error detected. Retrieve the error message 
C              and print it.
C Parameters:
C              None
C
      subroutine Print_Error
      exec sql include sqlca
      exec sql begin declare section
           character*200     error_buf
      exec sql end declare section
      exec sql inquire_sql (:error_buf = ERRORTEXT)
      print *, 'SQL Error:'
      print *, error_buf
      return
      end

C
C Function:Read_Stmt
C Purpose: Reads a statement from standard input. This routine
C          prompts the user for input (using a statement 
C          number) and scans input tokens for the statement 
C          delimiter (semicolon). The scan continues 
C          over new lines, and uses SQL string literal
C          rules.
C Parameters:
C            stmt_num - Statement number for prompt.
C            stmt_buf - Buffer to fill for input.
C Returns:
C           TRUE if a statement was read, FALSE if 
C          end-of-file typed.
C
      integer function Read_Stmt(stmt_num, stmt_buf)

      integer         stmt_num
      character*(*)   stmt_buf
      integer      stmt_max
      integer      sl
      character   input_buf(256)
      integer     line_len
      integer     i

      logical     in_string
      logical     current_line
      stmt_max = len(stmt_buf)

C    Prompt user for SQL statement.
110   write (*, 111) stmt_num
111   format (' ', I3, ' ', $)
      stmt_buf = ' '
      in_string = .false.
      sl = 1

C   Loop while scanning input for statement terminator.
      do while (.TRUE.)

C   Read input line up to the number of characters entered
           read (*, 112, err = 119, end = 119) line_len,
     1          (input_buf(i), i = 1, line_len)
112        format (Q, 100A1)

           current_line = .true. ! We are in a line
C
C Keep processing while we can (we have not reached the end of
C the line, and our statement buffer is not full).
C 
           i = 1
           do while (current_line .and. (sl .le. stmt_max))

C     Not in string - check for delimiters and new lines
                if (.not. in_string) then
                     if (i .gt. line_len) then
C                 New line outside of string is replaced with blank
                          input_buf(i) = ' '
                          current_line = .false.
                     else if (input_buf(i) .eq. ';') then
                          Read_Stmt = .true.
                          return
                     else if (input_buf(i) .eq. '''') then
                          in_string = .true.
                     end if
                     stmt_buf(sl:sl) = input_buf(i)
                     sl = sl + 1
                     i = i + 1
                else

C     End of line inside string is ignored
                     if (i .gt. line_len) then
                          current_line = .false.
                     else if (input_buf(i) .eq. '''') then
                          in_string = .false.
                     end if
                     if (current_line) then
                          stmt_buf(sl:sl) = input_buf(i)
                          sl = sl + 1
                          i = i + 1
                     end if
                end if
           end do
C
C Dropped out of above loop because end of line reached or buffer
C limit exceeded.
C

C Statement is too large - ignore it and try again.
           if (sl .gt. stmt_max) then
                write (*, 113) stmt_max
113             format (' SQL Error: Maximum statement length 
     1                 (', I4,') exceeded.')
                goto 110
           else
                write (*, 114)
114             format (' ---> ', $)
           end if
      end do
119   Read_Stmt = .false.
      return
      end

C
C Procedure: UsrDataHandler
C Purpose:   Use GET DATA to get the BLOB from the database.
C Parameters:
C            hdlarg - the structure with handler info
    
      subroutine UsrDataHandler (hdlarg)
      
      exec sql include sqlca
      
      exec sql whenever sqlerror stop
      
      exec sql begin declare section
            structure /hdlr_arg/
                character*50 argstr
                 integer     arglen
            end structure
            record /hdlr_arg/ hdlarg

            character*50      segbuf
            integer*4         dataend
            integer*4         seglen
      exec sql end declare sections

      integer totlen
      integer nsegs

      if (hdlarg.arglen .gt. len(hdlarg.argstr)) then
          hdlarg.arglen = len(hdlarg.argstr)
          write (*,120) hdlarg.arglen
120       format ('BLOB length error....reducing to: ',I)
      end if

      nsegs = 0
      totlen = 0
      dataend = 0
      do while ((dataend .eq. 0) .and. (totlen .lt. hdlarg.arglen))
           segbuf= ' '
           exec sql get data (:segbuf  = segment,
     1                         :seglen  = segmentlength,
     2                         :dataend = dataend)
     3          with maxlength = :hdlarg.arglen;

           hdlarg.argstr(totlen+1:) = segbuf(1:seglen)

           nsegs = nsegs + 1
           totlen = totlen + seglen
      end do

      if (dataend .eq. 0) then
           exec sql enddata;
      end if

      end