;;; Sam Thibault
;;; ODBC/SQL interface for scsh
;;; Spring 1999

;;; This is file: odbc0.scm

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; General Comments
;;; ----------------
;;; This file contains define-foreigns that link to stubs in odbc0.c, a file
;;; automatically generated with cig.  The C definitiions are located in two
;;; separate files: 
;;;
;;;      /solidSDK30/Solaris_SPARC/lib/sclssx30.so contains definitions of the
;;;        ODBC functions in the first half of this file.
;;;
;;;      scch-sql.o (compiled from scsh-sql.c) contains the definitions of the
;;;        functions in the second half of this file (used for allocating and 
;;;        freeing memory, and converting some data types.  
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; The headers below will be included in C file the generated by cig

(foreign-source
  "#if 0"
  "#include \"cli0cli.h\""
  "#include \"cli0defs.h\""
  "#include \"cli0env.h\""
  "#else"
  "#include <windows.h>"
  "#include <sql.h>"
  "#include <sqlext.h>"
  "#endif"
  "")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; ODBC Functions
;;; ---------------
;;; These define-foreigns link to ODBC functions defined in sclssx30.so
;;; This set contains all ODBC core functions.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; SQLAllocConnect allocates memory for a connection handle within the 
;;; identified environment.

(define-foreign %alloc-connect
  ("SQLAllocConnect" ((C "SQLHENV~a") environment)
                     ((C "SQLHDBC*~a") connection))
  (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM"))

;;; SQLAllocEnv allocates memory for an environment handle and initializes the
;;; ODBC call level interface for use by an application.  AllocEnv must be 
;;; called before any other ODBC function can be called.

(define-foreign %alloc-env
  ("SQLAllocEnv" ((C "SQLHENV*~a") pSQLHENV))
  (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM"))

;;; SQLAllocStmt allocates memory for a statement handle and associates the 
;;; statement handle with the specified connection. AllocStmt must be called 
;;; before executing any SQL statements.

(define-foreign %alloc-stmt
  ("SQLAllocStmt" ((C "SQLHDBC ~a") connection)
                  ((C "SQLHSTMT*~a") statement))
  (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM"))

;;; SQLBindCol assigns storage and data type for a column in a result set.

(define-foreign %bind-col
  ("SQLBindCol" ((C "SQLHSTMT ~a") statement)
                ((rep integer? "UWORD ~a" "EXTRACT_FIXNUM") column-number)
                ((rep integer? "SWORD ~a" "EXTRACT_FIXNUM") data-type)
                ((C "PTR ~a") storage-pointer)
                ((rep integer? "SDWORD ~a" "EXTRACT_FIXNUM") buffer-length)
                ((C "SDWORD*~a") available-bytes))
  (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM"))

;;; SQLBindParameter binds a buffer to a parameter marker in an SQL statement.

(define-foreign %bind-parameter
  ("SQLBindParameter" ((C "SQLHSTMT ~a") statement)
		      ((rep integer? "UWORD ~a" "EXTRACT_FIXNUM") param-number)
		      ((rep integer? "SWORD ~a" "EXTRACT_FIXNUM") param-type)
		      ((rep integer? "SWORD ~a" "EXTRACT_FIXNUM") c-datatype)
		      ((rep integer? "SWORD ~a" "EXTRACT_FIXNUM") sql-datatype)
		      ((rep integer? "UDWORD ~a" "EXTRACT_FIXNUM") precision)
		      ((rep integer? "SWORD ~a" "EXTRACT_FIXNUM") scale)
		      ((C "PTR ~a") storage-pointer)
		      ((rep integer? "SDWORD ~a" "EXTRACT_FIXNUM") buf-length)
		      ((C "SDWORD*~a") available-bytes))
  (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM"))

;;; SQLCancel cancels the processing on a statement.

(define-foreign %cancel
  ("SQLCancel" ((C "SQLHSTMT ~a") statement))
  (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM"))

;;; SQLColAttributes returns descriptor information for a cloumn in a result 
;;; set.

(define-foreign %col-attributes
  ("SQLColAttributes" ((C "SQLHSTMT ~a") statement)
                      ((rep integer? "UWORD ~a" "EXTRACT_FIXNUM") column-num)
                      ((rep integer? "UWORD ~a" "EXTRACT_FIXNUM") desc-type)
                      ((C "PTR ~a") storage-pointer)
                      ((rep integer? "SWORD ~a" "EXTRACT_FIXNUM") buf-length)
                      ((C "SWORD*~a") available-bytes)
                      ((C "SDWORD*~a") descriptor-pointer))
  (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM"))

;;; SQLConnect loads a driver and establishes a connection to the data source.

(define-foreign %connect
  ("SQLConnect" ((C "SQLHDBC ~a") connection)
                (string source-name)
                ((rep integer? "SWORD ~a" "EXTRACT_FIXNUM") source-name-length)
                (string user-name)
                ((rep integer? "SWORD ~a" "EXTRACT_FIXNUM") user-name-length)
                (string password)
                ((rep integer? "SWORD ~a" "EXTRACT_FIXNUM") password-length))
  no-declare
  (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM"))

;;; SQLDescribeCol returns the result descriptor for one column in a result 
;;; set.

(define-foreign %describe-col
  ("SQLDescribeCol" ((C "SQLHSTMT ~a") statment)
                    ((rep integer? "UWORD ~a" "EXTRACT_FIXNUM") column-number)
                    (string column-name)
                    ((rep integer? "SWORD ~a" "EXTRACT_FIXNUM") name-buffer-length)
                    ((C "SWORD*~a") bytes-available)
                    ((C "SWORD*~a") data-type)
                    ((C "UDWORD*~a") precision)
                    ((C "SWORD*~a") scale)
                    ((C "SWORD*~a") nullable))
  no-declare
  (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM"))

;;; SQLDescribeParam returns the description of a parameter marker associated 
;;; with a prepared SQL statement.

(define-foreign %describe-param
  ("SQLDescribeParam" ((C "SQLHSTMT ~a") statement)
		      ((rep integer? "UWORD ~a" "EXTRACT_FIXNUM") param-number)
		      ((C "SWORD*~a") sql-type)
		      ((C "UDWORD*~a") precision)
		      ((C "SWORD*~a") scale)
		      ((C "SWORD*~a") nullable))
  (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM"))

;;; SQLDisconnect closes the connection associated with a specific connection 
;;; handle.

(define-foreign %disconnect
  ("SQLDisconnect" ((C "SQLHDBC ~a") connection))
  (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM"))

;;; SQLError returns error or status information.

(define-foreign %sql-error
  ("SQLError" ((C "SQLHENV ~a") environment)
              ((C "SQLHDBC ~a") connection)
              ((C "SQLHSTMT ~a") statement)
              (string state)
              ((C "SDWORD*~a") error-code)
              (string error-message)
              ((rep integer? "SWORD ~a" "EXTRACT_FIXNUM") buffer-length)
              ((C "SWORD*~a") bytes-available))
  no-declare
  (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM"))

;;; SQLExecDirect executes a preparable statement.

(define-foreign %exec-direct
  ("SQLExecDirect" ((C "SQLHSTMT ~a") statement)
                   (string  sql-string)
                   ((rep integer? "SDWORD ~a" "EXTRACT_FIXNUM") string-length))
  no-declare
  (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM"))

;;; SQLExecute executes a prepared statement.

(define-foreign %execute
  ("SQLExecute" ((C "SQLHSTMT ~a") statement))
  (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM"))

;;; SQLFetch fetches a row of data from a result set.  The driver returns data
;;; for all columns that were bound to storage locations with BindCol.

(define-foreign %fetch
  ("SQLFetch" ((C "SQLHSTMT ~a") statement))
  (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM"))

;;; SQLFreeConnect releases a connection handle and frees all memory associated
;;; with the handle.

(define-foreign %free-connect
  ("SQLFreeConnect" ((C "SQLHDBC ~a") connection))
  (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM"))

;;; SQLFreeEnv frees the environment handle and frees all memory associated
;;; with the environment handle.

(define-foreign %free-env
  ("SQLFreeEnv" ((C "SQLHENV ~a") environment))
  (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM"))

;;; SQLFreeStmt stops processing associated with a specific statement handle,
;;; closes any open cursors, discards pending results, and, optionally, frees 
;;; all resources associated with the statement handle.

(define-foreign %free-stmt
  ("SQLFreeStmt" ((C "SQLHSTMT ~a") statement)
                 ((rep integer? "UWORD ~a" "EXTRACT_FIXNUM") option))
  (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM"))

;;; SQLGetCursorName returns the cursor name associated with a specified 
;;; statement handle.

(define-foreign %get-cursor-name
  ("SQLGetCursorName" ((C "SQLHSTMT ~a") statement)
                      (string cursor-name)
                      ((rep integer? "SWORD ~a" "EXTRACT_FIXNUM") name-length)
                      ((C "SWORD*~a") bytes-available))
  no-declare
  (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM"))

;;; SQLNumResultCols returns the number of columns in a result set.

(define-foreign %num-result-cols
  ("SQLNumResultCols" ((C "SQLHSTMT ~a") statement)
                      ((C "SWORD*~a") columns))
  (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM"))

;;; SQLPrepare prepares an SQL string for execution.

(define-foreign %prepare
  ("SQLPrepare" ((C "SQLHSTMT ~a") statement)
                (string sql-string)
                ((rep integer? "SDWORD ~a" "EXTRACT_FIXNUM") string-length))
  no-declare
  (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM"))

;;; SQLRowCount returns the number of rows affected by an UPDATE, INSERT, or
;;; DELETE statement.

(define-foreign %row-count
  ("SQLRowCount" ((C "SQLHSTMT ~a") statement)
                 ((C "SDWORD*~a") rows))
  (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM"))

;;; SQLSetCursorName associates a cursor name with an active statement handle.
;;; If an application does not call SetCursorName, the driver generates cursor
;;; names as needed for SQL statement processing.

(define-foreign %set-cursor-name
  ("SQLSetCursorName" ((C "SQLHSTMT ~a") statement)
                      (string cursor-name)
                      ((rep integer? "SWORD ~a" "EXTRACT_FIXNUM") name-length))
  no-declare
  (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM"))

;;; SQLTransact requests a commit or rollback operation for all active 
;;; operations on all statement handles associated with a connection.

(define-foreign %transact
  ("SQLTransact" ((C "SQLHENV ~a") environment)
                 ((C "SQLHDBC ~a") connection)
                 ((rep integer? "UWORD ~a" "EXTRACT_FIXNUM") option))
  (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Other Functions
;;; ---------------
;;; These define-foregins link to functions defined in scsh-sql.c.  These 
;;; functions are used for allocating and freeing memory in C that the ODBC 
;;; functions utilize.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Environment handles

(define *environment* #f)

(define-foreign make-environment
  (makesqlhenv)
  (C "SQLHENV*~a"))

(define-foreign de-ref-env
  (derefsqlhenv ((C "SQLHENV*~a") EnvPointer))
  (C "SQLHENV ~a"))

(define-foreign free-environment
  (freesqlhenv ((C "SQLHENV*~a") EnvPointer))
  bool)

;;; Connection handles

(define-foreign make-connection
  (makesqlhdbc)
  (C "SQLHDBC*~a"))

(define-foreign de-ref-con
  (derefsqlhdbc ((C "SQLHDBC*~a") DBCPointer))
  (C "SQLHDBC ~a"))

(define-foreign free-connection
  (freesqlhdbc ((C "SQLHDBC*~a") DBCPointer))
  bool)

;;; Statement handles

(define-foreign make-statement
  (makesqlhstmt)
  (C "SQLHSTMT*~a"))

(define-foreign de-ref-stmt
  (derefsqlhstmt ((C "SQLHSTMT*~a") StmtPointer))
  (C "SQLHSTMT ~a"))

(define-foreign free-statement
  (freesqlhstmt ((C "SQLHSTMT*~a") StmtPointer))
  bool)

;;; void* (unknown type)

(define-foreign make-storage
  ("makeStorage" ((C "SDWORD*~a") pcbValue))
  (C "void*~a"))

(define-foreign free-storage
  ("freeStorage" ((C "void*~a") rgbValue))
  bool)

;;; SDWORDs (long ints)

(define-foreign make-SDWORD
  ("makeSDWORD")
  (C "SDWORD*~a"))

(define-foreign de-ref-SDWORD
  ("derefSDWORD" ((C "SDWORD*~a") SDWORDpointer))
  (C "SDWORD ~a"))

(define-foreign extract-SDWORD
  ("extractSDWORD" ((C "SDWORD*~a") SDWORDpointer))
  (to-scheme (C "SDWORD ~a") "ENTER_FIXNUM"))

(define-foreign assign-SDWORD
  ("assignSDWORD" ((C "SDWORD*~a") SDWORDpointer)
		  (long value))
  bool)

(define-foreign free-SDWORD
  ("freeSDWORD" ((C "SDWORD*~a") SDWORDpointer))
  bool)

;;; UDWORDs (unsigned long ints)

(define-foreign make-UDWORD
  ("makeUDWORD")
  (C "UDWORD*~a"))

(define-foreign de-ref-UDWORD
  ("derefUDWORD" ((C "UDWORD*~a") UDWORDpointer))
  (C "UDWORD ~a"))

(define-foreign extract-UDWORD
  ("extractUDWORD" ((C "UDWORD*~a") UDWORDpointer))
  (to-scheme (C "UDWORD ~a") "ENTER_FIXNUM"))

(define-foreign free-UDWORD
  ("freeUDWORD" ((C "UDWORD*~a") UDWORDpointer))
  bool)

;;; SWORDs (short ints)

(define-foreign make-SWORD
  ("makeSWORD")
  (C "SWORD*~a"))

(define-foreign de-ref-SWORD
  ("derefSWORD" ((C "SWORD*~a") SWORDpointer))
  (C "SWORD ~a"))

(define-foreign extract-SWORD
  ("extractSWORD" ((C "SWORD*~a") SWORDpointer))
  (to-scheme (C "SWORD ~a") "ENTER_FIXNUM"))

(define-foreign assign-SWORD
  ("assignSWORD" ((C "SWORD*~a") SWORDpointer)
		  (long value))
  bool)

(define-foreign free-SWORD
  ("freeSWORD" ((C "SWORD*~a") SWORDpointer))
  bool)

;;; UCHARs (unsigned chars)

(define-foreign make-UCHAR
  ("makeUCHAR")
  static-string)

(define-foreign de-ref-UCHAR
  ("derefUCHAR" (string UCHARpointer))
  (C "UCHAR ~a"))

(define-foreign extract-UCHAR
  ("extractUCHAR" (string UCHARpointer))
  static-string)

(define-foreign free-UCHAR
  ("freeUCHAR" (string UCHARpointer))
  bool)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Getting values to Scheme
;;; ------------------------
;;; The following define foreigns enable ways to yank values
;;; in a C void* into Scheme.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-foreign void*->string
  ("VoidToString" ((C "PTR ~a") pointer))
  static-string)

(define-foreign void*->integer
  ("VoidToInteger" ((C "PTR ~a") pointer))
  integer)

(define (void*->number val)
  (string->number (void*->string val)))

;;; Date manipulations using sql-date records

(define-record sql-date
  seconds   ; Seconds after the minute [0-59] or #f
  minute    ; Minutes after the hour [0-59] or #f
  hour      ; Hours since midnight [0-23] or #f
  month-day ; Day of the month [1-31] or #f
  month     ; Months since January [1-12] or #f
  year)     ; Years since 1900 or #f

;;; Conversion from string into sql-date records

(define (void*->date val)
  (let ((date-string (void*->string val)))
    (make-sql-date #f #f #f 
		   (string->number (substring date-string 8 10))
		   (string->number (substring date-string 5 7))
		   (string->number (substring date-string 0 4)))))

(define (void*->time val)
  (let ((time-string (void*->string val)))
    (make-sql-date (substring time-string 6 8)
		   (substring time-string 3 5)
		   (substring time-string 0 2)
		   #f #f #f)))

(define (void*->timestamp val)
  (let ((timestamp-string (void*->string val)))
    (make-sql-date (string->number (substring timestamp-string 17 19))
		   (string->number (substring timestamp-string 14 16))
		   (string->number (substring timestamp-string 11 13))
		   (string->number (substring timestamp-string 8 10))
		   (string->number (substring timestamp-string 5 7))
		   (string->number (substring timestamp-string 0 4)))))

;;; Conversion from sql-date records into strings

(define (number->string/len n l)
  (let* ((s (number->string n))
	 (dif (- l (string-length n))))
    (case dif
      ((0) s)
      ((1) (string-append "0" s))
      ((2) (string-append "00" s))
      ((3) (string-append "000" s)))))
       
(define (sql-date->string d)
  (let ((sd (sql-date:seconds d))
	(mn (sql-date:minute d))
	(hr (sql-date:hour d))
	(md (sql-date:month-day d))
	(mo (sql-date:month d))
	(yr (sql-date:year d)))
    (cond ((and sd mn hr md mo yr) ;make timestamp
	     (string-append
	       (number->string/len yr 4) "-"
	       (number->string/len mo 2) "-"
	       (number->string/len md 2) " "
	       (number->string/len md 2) ":"
	       (number->string/len md 2) ":"
	       (number->string/len sd 2)))
	  ((and sd mn hr) ;make time
	   (string-append
	       (number->string/len md 2) ":"
	       (number->string/len md 2) ":"
	       (number->string/len sd 2)))
	  ((and md mo yr) ;make date
	   (string-append
	       (number->string/len yr 4) "-"
	       (number->string/len mo 2) "-"
	       (number->string/len md 2)))
	  (else (error "sql-date record contains incomplete fields" d)))))

;;; Conversion from scsh date record to sql-date record

(define (date->sql-date d)
  (make-sql-date (date:seconds d)
		 (date:minute d)
		 (date:hour d)
		 (date:month-day d)
		 (+ 1 (date:month d))
		 (date:year d)))

;;; Conversion from sql-date record to scsh date record
;;; This function may return an error if fields in sql-date record are #f.
;;; Raising an error here will prevent later scsh date manipulations from
;;; blowing up.

(define (sql-date->date d)
  (let ((sd (sql-date:seconds d))
	(mn (sql-date:minute d))
	(hr (sql-date:hour d))
	(md (sql-date:month-day d))
	(mo (sql-date:month d))
	(yr (sql-date:year d)))
    (if (and sd mn hr md mo yr)
	(make-date sd mn hr md (- mo 1) yr)
	(error "sql-date record contains incomplete fields" d))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Getting values to C
;;; -------------------
;;; The following define foreigns enable was to stuff values
;;; from Scheme into a C void*
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-foreign string->void*
  ("StringToVoid" (string-desc value)
		  ((C "PTR ~a") pointer))
  (C "void*~a"))

(define-foreign fixed-string->void*
  ("FixedStringToVoid" (string-desc value)
		       ((rep integer? "UDWORD ~a" "EXTRACT_FIXNUM") precision)
		       ((C "PTR ~a") pointer))
  (C "void*~a"))

(define (number->void* num ptr)
 (string->void* (number->string num) ptr))

(define-foreign integer->void*
  ("IntegerToVoid" (integer value)
		   ((C "PTR ~a") pointer))
  (C "void*~a"))