;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:          oracle.lisp
;;;; Purpose:       Package definition for CLSQL Oracle interface
;;;;
;;;; This file is part of CLSQL.
;;;;
;;;; CLSQL users are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************

(in-package #:clsql-oracle)

;;
;; OCI integer types
;;

(uffi:def-foreign-type ub2 :unsigned-short)
(uffi:def-foreign-type sb2 :short)
(uffi:def-foreign-type ub4 :unsigned-int)
(uffi:def-foreign-type sb4 :int)
(uffi:def-foreign-type size_t :unsigned-long)

;;
;; Opaque pointer types
;;

(uffi:def-foreign-type void-pointer :pointer-void)
(uffi:def-foreign-type oci-env :pointer-void)
(uffi:def-foreign-type oci-server :pointer-void)
(uffi:def-foreign-type oci-error :pointer-void)
(uffi:def-foreign-type oci-svc-ctx :pointer-void)
(uffi:def-foreign-type oci-stmt :pointer-void)

(uffi:def-pointer-var +null-void-pointer+
  (uffi:make-null-pointer :void))
(uffi:def-pointer-var +null-void-pointer-pointer+
  (uffi:make-null-pointer :pointer-void))

;;; Check an OCI return code for erroricity and signal a reasonably
;;; informative condition if so.
;;;
;;; ERRHP provides an error handle which can be used to find
;;; subconditions; if it's not provided, subcodes won't be checked.
;;;
;;; NULLS-OK says that a NULL-VALUE-RETURNED subcondition condition is
;;; normal and needn't cause any signal. An error handle is required
;;; to detect this subcondition, so it doesn't make sense to set ERRHP
;;; unless NULLS-OK is set.

(defmacro def-oci-routine ((c-oci-symbol lisp-oci-fn) c-return &rest c-parms)
  (let ((ll (mapcar (lambda (x) (declare (ignore x)) (gensym)) c-parms))
        (c-oci-fn (intern (concatenate 'string "%" (symbol-name lisp-oci-fn)))))
    `(progn
      (declaim (inline ,c-oci-fn ,lisp-oci-fn))
      (uffi:def-function (,c-oci-symbol ,c-oci-fn)
          ,c-parms
        :returning ,c-return)
      (defun ,lisp-oci-fn (,@ll &key database nulls-ok)
        (let ((result (,c-oci-fn ,@ll)))
          (if (= result #.+oci-success+)
              +oci-success+
              (handle-oci-result result database nulls-ok)))))))


(defmacro def-raw-oci-routine
  ((c-oci-symbol lisp-oci-fn) c-return &rest c-parms)
  (let ((ll (mapcar (lambda (x) (declare (ignore x)) (gensym)) c-parms)))
    `(let ((%lisp-oci-fn (uffi:def-function (,c-oci-symbol ,(intern (concatenate 'string "%" (symbol-name lisp-oci-fn))))
                             ,c-parms
                           :returning ,c-return)))
       (defun ,lisp-oci-fn (,@ll &key database nulls-ok)
         (declare (ignore database nulls-ok))
         (funcall %lisp-oci-fn ,@ll)))))


(def-oci-routine ("OCIInitialize" oci-initialize)
    :int
  (mode ub4)                                    ; ub4
  (ctxp :pointer-void)                  ; dvoid *
  (malocfp :pointer-void)                       ; dvoid *(*)
  (ralocfp :pointer-void)                       ; dvoid *(*)
  (mfreefp (* :pointer-void)))          ; void *(*)


(def-oci-routine ("OCIEnvInit" oci-env-init)
    :int
  (envpp :pointer-void)                         ; OCIEnv **
  (mode ub4)                                    ; ub4
  (xtramem-sz size_t)            ; size_t
  (usermempp (* :pointer-void)))                    ; dvoid **

#-oci7
(def-oci-routine ("OCIEnvCreate" oci-env-create)
    :int
  (envhpp (* :pointer-void))
  (mode ub4)
  (ctxp :pointer-void)
  (malocfp :pointer-void)
  (ralocfp :pointer-void)
  (mfreefp :pointer-void)
  (xtramemsz size_t)
  (usrmempp (* :pointer-void)))

(def-oci-routine ("OCIHandleAlloc" oci-handle-alloc)
    :int
  (parenth      :pointer-void)                  ; const dvoid *
  (hndlpp       (* :pointer-void))              ; dvoid **
  (type         ub4)                            ; ub4
  (xtramem_sz   size_t)                         ; size_t
  (usrmempp     (* :pointer-void)))             ; dvoid **

(def-oci-routine ("OCIServerAttach" oci-server-attach)
    :int
  (srvhp        :pointer-void)                  ; oci-server
  (errhp        :pointer-void)                  ; oci-error
  (dblink       :cstring)                       ; :in
  (dblink-len   sb4)                            ; sb4
  (mode         ub4))                           ; ub4


(def-oci-routine ("OCIHandleFree" oci-handle-free)
    :int
  (p0 :pointer-void) ;; handle
  (p1 ub4)) ;;type

(def-oci-routine ("OCILogon" oci-logon)
    :int
  (envhp        :pointer-void)          ; env
  (errhp        :pointer-void)          ; err
  (svchpp       (* :pointer-void))      ; svc
  (username     (* :unsigned-char))     ; username
  (uname-len    ub4)                    ;
  (passwd       (* :unsigned-char))     ; passwd
  (password-len ub4)                    ;
  (dsn          (* :unsigned-char))     ; datasource
  (dsn-len      ub4))                   ;

(def-oci-routine ("OCILogoff" oci-logoff)
    :int
  (p0   :pointer-void)        ; svc
  (p1   :pointer-void))       ; err

(declaim (inline oci-error-get))
(uffi:def-function ("OCIErrorGet" oci-error-get)
    ((handlp    :pointer-void)
     (recordno  ub4)
     (sqlstate  :cstring)
     (errcodep  (* sb4))
     (bufp      (* :unsigned-char))
     (bufsize   ub4)
     (type      ub4))
  :returning :void)

(def-oci-routine ("OCIStmtPrepare" oci-stmt-prepare)
    :int
  (stmtp      :pointer-void)
  (errhp      :pointer-void)
  (stmt       (* :unsigned-char))
  (stmt_len   ub4)
  (language   ub4)
  (mode       ub4))

(def-oci-routine ("OCIStmtExecute" oci-stmt-execute)
    :int
  (svchp      :pointer-void)
  (stmtp1     :pointer-void)
  (errhp      :pointer-void)
  (iters      ub4)
  (rowoff     ub4)
  (snap_in    :pointer-void)
  (snap_out   :pointer-void)
  (mode       ub4))

(def-raw-oci-routine ("OCIParamGet" oci-param-get)
    :int
  (hndlp      :pointer-void)
  (htype      ub4)
  (errhp      :pointer-void)
  (parmdpp    (* :pointer-void))
  (pos        ub4))

(def-oci-routine ("OCIAttrGet" oci-attr-get)
    :int
  (trgthndlp  :pointer-void)
  (trghndltyp ub4)
  (attributep :pointer-void)
  (sizep      (* ub4))
  (attrtype   ub4)
  (errhp      :pointer-void))

(def-oci-routine ("OCIAttrSet" oci-attr-set)
    :int
  (trgthndlp   :pointer-void)
  (trgthndltyp ub4 :in)
  (attributep  :pointer-void)
  (size        ub4)
  (attrtype    ub4)
  (errhp       oci-error))

(def-oci-routine ("OCIDefineByPos" oci-define-by-pos)
    :int
  (stmtp      :pointer-void)
  (defnpp     (* :pointer-void))
  (errhp      :pointer-void)
  (position   ub4)
  (valuep     :pointer-void)
  (value_sz   sb4)
  (dty        ub2)
  (indp       (* sb2))
  (rlenp      (* ub2))
  (rcodep     (* ub2))
  (mode       ub4))

(def-oci-routine ("OCIStmtFetch" oci-stmt-fetch)
    :int
  (stmthp       :pointer-void)
  (errhp        :pointer-void)
  (p2           ub4)
  (p3           ub2)
  (p4           ub4))


(def-oci-routine ("OCITransStart" oci-trans-start)
  :int
  (svchp        :pointer-void)
  (errhp        :pointer-void)
  (p2           :unsigned-short)
  (p3           :unsigned-short))

(def-oci-routine ("OCITransCommit" oci-trans-commit)
  :int
  (svchp        :pointer-void)
  (errhp        :pointer-void)
  (p2           :unsigned-short))

(def-oci-routine ("OCITransRollback" oci-trans-rollback)
    :int
  (svchp       :pointer-void)
  (errhp        :pointer-void)
  (p2           :unsigned-short))


(def-oci-routine ("OCIServerVersion" oci-server-version)
    :int
    (handlp    :pointer-void)
    (errhp     :pointer-void)
    (bufp      (* :unsigned-char))
    (bufsz     :int)
    (hndltype  :short))



;;; Low-level routines that don't do error checking. They are used
;;; for setting up global environment.

(uffi:def-function "OCIInitialize"
    ((mode ub4)                                 ; ub4
     (ctxp :pointer-void)                       ; dvoid *
     (malocfp :pointer-void)                    ; dvoid *(*)
     (ralocfp :pointer-void)                    ; dvoid *(*)
     (mfreefp (* :pointer-void)))
  :returning :int)

(uffi:def-function "OCIEnvInit"
    ((envpp :pointer-void)                      ; OCIEnv **
     (mode ub4)                                 ; ub4
     (xtramem-sz size_t)                        ; size_t
     (usermempp (* :pointer-void)))
  :returning :int)


(uffi:def-function "OCIHandleAlloc"
    ((parenth      :pointer-void)               ; const dvoid *
     (hndlpp       (* :pointer-void))           ; dvoid **
     (type         ub4)                         ; ub4
     (xtramem_sz   size_t)                      ; size_t
     (usrmempp     (* :pointer-void)))
  :returning :int)

(defstruct oci-handle
  (type :unknown)
  (pointer (uffi:allocate-foreign-object :pointer-void)))

(defvar *oci-initialized* nil)
(defvar *oci-env* nil)

(defvar *oci-handle-types*
  '(:error                              ; error report handle (OCIError)
    :service-context                    ; service context handle (OCISvcCtx)
    :statement                          ; statement (application request) handle (OCIStmt)
    :describe                           ; select list description handle (OCIDescribe)
    :server                             ; server context handle (OCIServer)
    :session                            ; user session handle (OCISession)
    :transaction                        ; transaction context handle (OCITrans)
    :complex-object                     ; complex object retrieval handle (OCIComplexObject)
    :security))                         ; security handle (OCISecurity)



(defun oci-init (&key (mode +oci-default+))
  (let ((x (OCIInitialize mode +null-void-pointer+ +null-void-pointer+
                          +null-void-pointer+ +null-void-pointer-pointer+)))
    (if (= x 0)
        (let ((env (uffi:allocate-foreign-object :pointer-void)))
          (setq *oci-initialized* mode)
          (let ((x (OCIEnvInit env +oci-default+ 0 +null-void-pointer+)))
            (format t ";; OEI: returned ~d~%" x)
            (setq *oci-env* env))))))

(defun oci-check-return (value)
  (when (= value +oci-invalid-handle+)
    (error 'sql-database-error :message "Invalid Handle")))

(defun oci-get-handle (&key type)
  (if (null *oci-initialized*)
      (oci-init))
  (case type
    (:error
     (let ((ptr (uffi:allocate-foreign-object :pointer-void)))
       (let ((x (OCIHandleAlloc
                 (uffi:deref-pointer *oci-env* void-pointer)
                 ptr
                 +oci-default+
                 0
                 +null-void-pointer-pointer+)))
         (oci-check-return x)
         ptr)))
    (:service-context
     "OCISvcCtx")
    (:statement
     "OCIStmt")
    (:describe
     "OCIDescribe")
    (:server
     "OCIServer")
    (:session
     "OCISession")
    (:transaction
     "OCITrans")
    (:complex-object
     "OCIComplexObject")
    (:security
     "OCISecurity")
    (t
     (error 'sql-database-error
            :message
            (format nil "'~s' is not a valid OCI handle type" type)))))

(defun oci-environment ()
  (let ((envhp (oci-get-handle :type :env)))
    (oci-env-init envhp 0 0 +null-void-pointer+)
    envhp))
