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

;;; This is file: odbc2.scm

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; General Comments
;;; ----------------
;;; This file contains the functions used by scsh-sql.scm.  These functions
;;; are the original define-foreigns for the ODBC functions (from odbc0.scm)
;;; enclosed in the scsh-sql error system (in odbc1.scm).  These functions also
;;; handling all the neccesary memory allocation the ODBC functions require.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Values defined by ODBC

(define sql-param-input 1)
(define sql-c-default 99)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Scheme Names
;;; ------------
;;; The define-foreigns for ODBC library functions (in odbc0.scm) rename the 
;;; functions by replacing the beginning "SQL" with "%" and hyphenating the 
;;; function name.  For example "SQLAllocConnect" becomes "%alloc-connect".  
;;; The function used by scsh-sql.scm is the name without the "%".  These 
;;; functions are created below by encapsulating the %-name within a translate-
;;; return and doing neccesary memory allocation within the function.  This 
;;; provides a clean Scheme-like interface for scsh-sql.scm
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; alloc-connect allocates memory for a connection handle within the 
;;; environment returned from server-env.

(define (alloc-connect)
  (let ((con (make-connection))
        (env (de-ref-env (server-env))))
    (translate-return (%alloc-connect env con)
                      'alloc-connect
                      *environment*
                      con
                      #f)
    con))

;;; server-env checks if an environment handle has been created.  If there is
;;; a current henv it returns it; otherwise, server-env allocates a new henv
;;; sets it as the current henv, and returns the henv.
;;;
;;; server-env was renamed from alloc-env because this function only allocates
;;; a new environment handle if none exists.

(define (server-env)
  (if (not *environment*)
      (let ((env (make-environment)))
        (translate-return (%alloc-env env)
                          'server-env
                          env
                          #f
                          #f)
        (set! *environment* env)))
  *environment*)

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

(define (alloc-stmt con)
  (let ((stmt (make-statement)))
    (translate-return (%alloc-stmt (de-ref-con con)
                                   stmt)
                      'alloc-stmt
                      #f                ; env handle ignored by sql-error
                      con
                      stmt)
    stmt))

;;; bind-col assigns storage and data type for a column in a result set.  The
;;; newly created storage, "target" is returned.

(define (bind-col cmd icol type precision)
  (let ((p (make-SDWORD))
        (stmt (sql-command:statement cmd)))
    (assign-SDWORD p precision)
    (let* ((target-size p)
           (target (make-storage target-size)))
      (translate-return (%bind-col (de-ref-stmt stmt) 
                                   icol 
                                   (if (or (= type sql/integer)
                                           (= type sql/smallint))
                                       type
                                       sql/char)
                                   target
                                   (if (or (= type sql/integer)
                                           (= type sql/smallint))
                                       (extract-SDWORD target-size)
                                       (+ 1 (extract-SDWORD target-size)))
                                   target-size)
                        'bind-col
                        #f              ; env handle ignored by sql-error
                        #f              ; con handle ignored by sql-error
                        stmt)
      target)))

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

(define (bind-parameter cmd coln data-type precision scale param)
  ;; create buffers
  (receive (target-size)
           (cond ((= data-type sql/char)
                  (assign-SDWORD (make-SDWORD) (+ 1 precision)))
                 ((or (= data-type sql/numeric)
                      (= data-type sql/decimal)
                      (= data-type sql/float)
                      (= data-type sql/real)
                      (= data-type sql/double))
                  (assign-SDWORD (make-SDWORD)
                                 (+ 1 (string-length (number->string param)))))
                 ((or (= data-type sql/integer)
                      (= data-type sql/smallint))
                  (assign-SDWORD (make-SDWORD) precision))
                 ((= data-type sql/varchar)
                  (assign-SDWORD (make-SDWORD) (string-length param)))
                 (else (error "unsupported parameter type: "
                              (type-val->string data-type))))
           (receive (target)
                    (cond ((= data-type sql/char)
                           (fixed-string->void* param precision 
                                                (make-storage target-size)))
                          ((or (= data-type sql/numeric)
                               (= data-type sql/decimal)
                               (= data-type sql/float)
                               (= data-type sql/real)
                               (= data-type sql/double))
                           (number->void* param (make-storage target-size)))
                          ((or (= data-type sql/integer)
                               (= data-type sql/smallint))
                           (integer->void* param (make-storage target-size)))
                          ((= data-type sql/varchar)
                           (string->void* param (make-storage target-size)))
                          (else (error "unsupported parameter type: "
                                       (type-val->string data-type))))
                    ;; do it
                    (let ((stmt (sql-command:statement cmd)))
                      (translate-return (%bind-parameter (de-ref-stmt stmt)
                                                         coln
                                                         sql-param-input
                                                         sql-c-default
                                                         data-type 
                                                         precision 
                                                         scale 
                                                         target ;storage-pointer 
                                                         (extract-SDWORD target-size) ;buf-lng
                                                         target-size ;available-bytes
                                                         'bind-parameter
                                                         #f ; env handle ignored by sql-error
                                                         #f ; con handle ignored by sql-error
                                                         stmt))))))

;;; cancel cancels the processing on a statement.

(define (cancel cmd)
  (let ((stmt (sql-command:statement cmd)))
    (translate-return (%cancel (de-ref-stmt stmt))
                      'cancel
                      #f                ; env handle ignored by sql-error
                      #f                ; con handle ignored by sql-error
                      stmt)))

;;; col-attributes returns descriptor information for a cloumn in a result set.

;;; col-attributes descriptor types:
(define column-auto-increment 11) ; pfDesc (int return in desriptor-pointer)
(define column-case-sensitive 12) ; pfDesc
(define column-count 0)           ; pfDesc
(define column-display-size 6)    ; pfDesc
(define column-length 3)          ; pfDesc
(define column-money 9)           ; pfDesc
(define column-name 1)            ; rgbDesc (string return in storage-pointer)
(define column-nullable 7)        ; pfDesc
(define column-precision 4)       ; pfDesc
(define column-scale 5)           ; pfDesc
(define column-searchable 13)     ; pfDesc
(define column-data-type 2)       ; pfDesc
(define column-type-name 14)      ; pfDesc
(define column-unsigned 8)        ; pfDesc
(define column-updatable 10)      ; pfDesc

(define (col-attributes stmt column-number descriptor-type storage-pointer
                        buffer-length available-bytes descriptor-pointer)
  (translate-return (%col-attributes stmt column-number descriptor-type
                                     storage-pointer buffer-length
                                     available-bytes descriptor-pointer)
                    'col-attributes
                    #f                  ; env handle ignored by sql-error
                    #f                  ; con handle ignored by sql-error
                    stmt))

;;; connect creates a new connection, loads a driver, and establishes a 
;;; connection to the data source using the new connection.

(define (connect source-name user-name password)
  (let ((con (alloc-connect)))
    (translate-return (%connect con
                                source-name (string-length source-name)
                                user-name (string-length user-name)
                                password (string-length password))
                      'connect
                      #f
                      con
                      #f)
    con))

;;; connect! loads a driver, and establishes a connection to the data source 
;;; using the supplied connection.

(define (connect! con source-name user-name password)
  (translate-return (%connect (de-ref-con con)
                              source-name (string-length source-name)
                              user-name (string-length user-name)
                              password (string-length password))
                    'connect
                    *environment*
                    con
                    #f))

;;; describe-col returns the result descriptor for one column in a result set.

(define (describe-col cmd icol)
  (let ((stmt (sql-command:statement cmd))
        (name (make-string 1))
        (name-byte-size (make-SWORD))
        (data-type (make-SWORD))
        (precision (make-UDWORD))
        (scale (make-SWORD))
        (nullable (make-SWORD)))
    (with-sql-info-handler*
     (lambda (func code mess henv hdbc hstmt) #t)
     (lambda ()
       (translate-return (%describe-col (de-ref-stmt stmt) icol name
                                        (+ 1 (string-length name))
                                        name-byte-size data-type precision
                                        scale nullable)
                         'describe-col
                         #f             ; env handle ignored by sql-error
                         #f             ; con handle ignored by sql-error
                         stmt)))
    (set! name (make-string (extract-SWORD name-byte-size)))
    (translate-return (%describe-col (de-ref-stmt stmt) icol name
                                     (+ 1 (string-length name))
                                     name-byte-size data-type precision
                                     scale nullable)
                      'describe-col
                      #f                ; env handle ignored by sql-error
                      #f                ; con handle ignored by sql-error
                      stmt)
    (values name (extract-SWORD name-byte-size) (extract-SWORD data-type)
            (extract-UDWORD precision) (extract-SWORD scale)
            (extract-SWORD nullable))))

;;; describe-param returns the description of a parameter marker associated 
;;; with a prepared SQL statement.

(define (describe-param cmd coln)
  (let ((stmt (sql-command:statement cmd))
        (data-type (make-SWORD))
        (precision (make-UDWORD))
        (scale (make-SWORD))
        (nullable (make-SWORD)))
    (translate-return (%describe-param (de-ref-stmt stmt) coln data-type
                                       precision scale nullable)
                      'describe-param
                      #f                ; env handle ignored by sql-error
                      #f                ; con handle ignored by sql-error
                      stmt)
    (values (extract-SWORD data-type)
            (extract-UDWORD precision)
            (extract-SWORD scale)
            (extract-SWORD nullable))))

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

(define (disconnect con)
  (translate-return (%disconnect (de-ref-con con))
                    'disconnect
                    #f
                    con
                    #f))

;;; sql-error: see error-system in file odbc1.scm

;;; execdirect executes a preparable statement.

(define (exec-direct stmt sql-string)
  (translate-return (%exec-direct stmt sql-string (string-length sql-string))
                    'exec-direct
                    #f                  ; env handle ignored by sql-error
                    #f                  ; con handle ignored by sql-error
                    stmt))

;;; execute executes a prepared statement.

(define (execute stmt)
  (translate-return (%execute (de-ref-stmt stmt))
                    'execute
                    #f                  ; env handle ignored by sql-error
                    #f                  ; con handle ignored by sql-error
                    stmt))

;;; fetch fetches a row of data from a result set.  The driver returns data
;;; for all columns that were bound to storage locations with bind-col.

(define (fetch cursor)
  (if (not (translate-return (%fetch (de-ref-stmt (cursor:stmt cursor)))
                             'fetch
                             #f         ; env handle ignored by sql-error
                             #f         ; con handle ignored by sql-error
                             (cursor:stmt cursor)))
      ;; close the cursor if no more rows
      (begin (close-cursor cursor)
             #f)                        ; #f for multi-fetch operations

      ;; otherwise build the row
      (let* ((ncols (cursor:ncols cursor))
             (row (make-vector ncols))
             (cd (cursor:col-data cursor)))
        (let get-cols ((i 0))
          (cond ((< i ncols)
                 (vector-set! 
                  row i ((cond
                          ((or (= (column-type cd i) sql/char)
                               (= (column-type cd i) sql/varchar))
                           void*->string)
                          
                          ((or (= (column-type cd i) sql/numeric)
                               (= (column-type cd i) sql/decimal)
                               (= (column-type cd i) sql/float)
                               (= (column-type cd i) sql/real) 
                               (= (column-type cd i) sql/double))
                           void*->number)

                          ((or (= (column-type cd i) sql/integer)
                               (= (column-type cd i) sql/smallint))
                           void*->integer)

                          ((= (column-type cd i) sql/date)
                           void*->date)

                          ((= (column-type cd i) sql/time)
                           void*->time)

                          ((= (column-type cd i) sql/timestamp)
                           void*->timestamp)

                          (else (error "can't convert type: fetch-rows")))
                         (column-target cd i)))
                 (get-cols (+ i 1)))))
        row)))

;;; free-connect releases a connection handle and frees all memory associated
;;; with the handle.

(define (free-connect con)
  (translate-return (%free-connect (de-ref-con con))
                    'free-connect
                    #f
                    con
                    #f)
  (free-connection con))

;;; free-env frees the environment handle and frees all memory associated
;;; with the environment handle and sets the *environment* variable to #f.

(define (free-env)
  (let ((env (if *environment*
                 *environment*
                 (error "no current environment"))))
    (translate-return (%free-env (de-ref-env env))
                      'free-env
                      env
                      #f
                      #f)
    (free-environment env)
    (set! *environment* #f)
    #t))

;;; free-stmt 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.
;;;
;;; SQLFreeStmt Flags:
;;; 
;;; flag = means this
;;; -----=-----------------
;;;   0  = SQL_CLOSE
;;;   1  = SQL_DROP
;;;   2  = SQL_UNBIND
;;;   3  = SQL_RESET_PARAMS

(define (free-stmt/close stmt)
  (translate-return (%free-stmt (de-ref-stmt stmt) 0)
                    'free-stmt
                    #f
                    #f
                    stmt)
  (free-statement stmt)
  #t)

(define free-stmt free-stmt/close)

(define (free-stmt/drop stmt)
  (translate-return (%free-stmt (de-ref-stmt stmt) 1)
                    'free-stmt
                    #f
                    #f
                    stmt)
  (free-statement stmt)
  #t)

(define (free-stmt/unbind stmt)
  (translate-return (%free-stmt (de-ref-stmt stmt) 2)
                    'free-stmt
                    #f
                    #f
                    stmt))

(define (free-stmt/reset stmt)
  (translate-return (%free-stmt (de-ref-stmt stmt) 3)
                    'free-stmt
                    #f
                    #f
                    stmt))

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

(define (get-cursor-name statement cursor-name name-length bytes-available)
  (translate-return (%get-cursor-name statement cursor-name name-length
                                      bytes-available)
                    'get-cursor-name
                    #f                  ; env handle ignored by sql-error
                    #f                  ; con handle ignored by sql-error
                    statement))

(define (cursor-name? cursor)
  (let ((c-name (make-string 65))
        (c-avail (make-SWORD)))
    (assign-SWORD c-avail 64)
    (get-cursor-name (de-ref-stmt (cursor:stmt cursor)) c-name 64 c-avail)
    c-name))

;;; num-result-cols returns the number of columns in a result set.

(define (num-result-cols cmd)
  (let ((stmt (sql-command:statement cmd))
        (ncols (make-SWORD)))
    (translate-return (%num-result-cols (de-ref-stmt stmt) ncols)
                      'num-result-cols
                      #f ; env handle ignored by sql-error
                      #f ; con handle ignored by sql-error
                      stmt)
    (extract-SWORD ncols)))

;;; prepare allocates a new connection and statement handle and prepares an 
;;; SQL string for execution with that hstmt.  The new hstmt is returned.

(define (prepare sql-str db)
  (let* ((con (db:con db))
         (stmt (alloc-stmt con)))
    (translate-return (%prepare (de-ref-stmt stmt) sql-str 
                                (string-length sql-str))
                      'prepare
                      #f ; env handle ignored by sql-error
                      #f ; con handle ignored by sql-error
                      stmt)
    stmt))


;;; prepare! prepares an SQL string for execution with the provided hstmt.

(define (prepare! stmt sql-str)
  (translate-return (%prepare (de-ref-stmt stmt) sql-str 
                              (string-length sql-str))
                    'prepare
                    #f ; env handle ignored by sql-error
                    #f ; con handle ignored by sql-error
                    stmt))

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

(define (row-count cmd)
  (let ((stmt (sql-command:statement cmd))
        (rows (make-SDWORD)))
    (translate-return (%row-count (de-ref-stmt stmt) rows)
                      'row-count
                      #f ; env handle ignored by sql-error
                      #f ; con handle ignored by sql-error
                      stmt)
    (extract-SDWORD rows)))

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

(define (set-cursor-name! cursor cursor-name)
  (translate-return (%set-cursor-name (de-ref-stmt (cursor:stmt cursor))
                                      cursor-name 
                                      (string-length cursor-name))
                    'set-cursor-name!
                    #f ; env handle ignored by sql-error
                    #f ; con handle ignored by sql-error
                    (cursor:stmt cursor)))

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

(define (transact con option)
  (let ((env (de-ref-env (server-env))))
    (translate-return (%transact env (de-ref-con con) option)
                      'transact
                      *environment*
                      con
                      #f)))
;;; transact OPTION must be one of these:
(define sql-commit 0)
(define sql-rollback 1) 

(define *current-db* (make-fluid #f))
(define (current-db) (fluid *current-db*))

(define (with-current-db* db thunk)
  (let-fluid *current-db* db
             thunk))

(define-syntax with-current-db
  (syntax-rules ()
    ((with-current-db db body1 body2 ...) 
     (with-current-db* db (lambda () body1 body2 ...)))))

(define (call/db host user password proc)
  (let ((db (open-db host user password)))
    (dynamic-wind (lambda () #t)
        (lambda () (proc db))
        (lambda () (close-db db)))))

(define (with-open-db* host user password thunk)
  (call/db host user password (lambda (db) (let-fluid *current-db* db thunk))))

(define-syntax with-open-db
  (syntax-rules ()
    ((with-open-db dbname user pwd body1 body2 ...)
     (with-open-db* dbname user pwd (lambda () body1 body2 ...)))))

(define-record sql-command
  sql-string ;actual string of sql query, e.g. "select * from ..."
  statement  ;ODBC statement handle
  prep)      ;#t if statement has been prepared by odbc command PREPARE

(define (string->sql-command sql-string)
  (make-sql-command sql-string
                    #f
                    #f))

(define-record db
  con) ; ODBC connection handle

(define (open-db host user password)
  (let ((con (alloc-connect)))
    (connect! con host user password)
    (make-db con)))

(define (set-current-db! d)
  (if (not (db? d))
      (error "Error: set-current-db! must be called with a db as argument.")
      (set-fluid! *current-db* d))
  d)

(define (close-db . maybe-d)
  (let* ((db (:optional maybe-d (current-db)))
         (con (db:con db)))
    (disconnect con)
    (free-connect con)
    #t))

(define (execute-sql command . args)
  (receive (db params) (if (null? args)
                           (values (current-db) '())
                           (values (car args) (cdr args)))
           (let* ((con (db:con db))
                  (cmd (if (sql-command? command)
                           (begin (if (not (sql-command:statement command))
                                      (set-sql-command:statement 
                                       command (alloc-stmt con)))
                                  command)
                           (make-sql-command command (alloc-stmt con) #f)))
                  (stmt (sql-command:statement cmd)))
             
             ;; Prepare the statement if it's not already prepared.
             (if (not (sql-command:prep cmd))
                 (begin (prepare! stmt (sql-command:sql-string cmd))
                        (set-sql-command:prep cmd #t)))

             ;; Do it.
             (let ((ncols (num-result-cols cmd)))
               (if (not (null? params)) 
                   (bind-params cmd params))
               (execute stmt)
               (let* ((nrows (row-count cmd))
                      (answer (cond ((> nrows 0) nrows) ;delete,insert,update
                                    ((= ncols 0) #t)    ;make table
                                    (else               ;select
                                     (let ((cursor (prepare-cursor cmd ncols)))
                                       (set-sql-command:prep cmd #f)
                                       (set-sql-command:statement cmd #f)
                                       cursor)))))
                 ;;(if (not (cursor? answer)) ;different free-stmts
                 ;; (free-stmt stmt))
               answer)))))

(define (bind-params cmd params)
  (let iter ((coln 1) (prms params))
    (if (null? prms)
        cmd
        ;; get info for each column
        (let ((val (car prms)))
          (receive (data-type precision scale nullable)
                   (describe-param cmd coln)
                   ;; bind it
                   (bind-parameter cmd
                                   coln
                                   data-type
                                   precision
                                   scale
                                   (cond ((date? val) 
                                          (sql-date->string (date->sql-date val)))
                                         ((and (= data-type
                                                  (or sql/date
                                                      sql/time
                                                      sql/timestamp))
                                               (integer? val))
                                          (sql-date->string
                                           (date->sql-date (date val))))
                                         (else val)))
                   ;; bind next parameter
                   (iter (+ 1 coln) (cdr prms)))))))

;; prepare to fetch rows of data

(define (prepare-cursor cmd ncols)
  (let ((col-data (make-table-desc (sql-command:statement cmd)
                                   (make-vector ncols))))
    (let iter ((icol 1))
      (if (<= icol ncols)
          ;; get info for column
          (receive (name name-size data-type precision scale nullable)
                   (describe-col cmd icol)
                   ;; bind it
                   (vector-set! (table-desc:cols col-data) 
                                (- icol 1)
                                (make-column-desc 
                                 name name-size data-type precision scale nullable
                                 (bind-col cmd icol data-type precision)))
                   ;; bind the next column
                   (iter (+ icol 1)))))
    (make-cursor col-data ncols (sql-command:statement cmd) cmd)))

;; fetching rows of data

(define fetch-row fetch)

(define (fetch-rows cursor nrows)
  (let recur ((nrows nrows))
    (if (zero? nrows) '()
        (let ((row (fetch-row cursor)))
          (if row
              (cons row (recur (- nrows 1)))
              '())))))

(define (fetch-all cursor)
  (let ((row (fetch-row cursor)))
    (if row
        (cons row (fetch-all cursor))
        '())))

;; closing a cursor to recycle statement handle

(define (cursor-closed? cursor)
  (not (cursor:cmd cursor)))

(define (close-cursor cursor)
  (or (cursor-closed? cursor) ;check if already closed
      (let ((stmt (cursor:stmt cursor))
            (cmd (cursor:cmd cursor)))
        (set-cursor:cmd cursor #f)
        (if (sql-command:statement cmd)
            (free-stmt/drop stmt)
            (set-sql-command:statement cmd (free-stmt/close stmt)))))
  #t)

;; commit or rollback

(define (commit db)
  (transact (db:con db) sql-commit))

(define (rollback db)
  (transact (db:con db) sql-rollback))