oracle.lisp

Oracle数据访问类

(defun column-names ()
  (join "~%" (map 'list #'sqlcol-name (columns))))


; GETHASH-REQUIRED
; Get the value of a column - must exist if the hash table is non-empty
(defun gethash-required (key hash)
  (if (= 0 (hash-table-count hash))
      nil
    (multiple-value-bind
     (val exists) (gethash (to-string key) hash)
     (when (not exists) (error (cat "DO-ROWS: bound variable '" key "' does not occur in the query."
                                    "~%The allowed column/variable names are:~%~%" (column-names)
                                    "~%")))
     val)))
                       
; ROW-TO-RESULT
; Convert fetched row array data to result type
(defun row-to-result (row result-type)
  (cond ((null row) nil)
        ((eq result-type 'ARRAY) row)
        ; ((eq result-type 'HASH) (pairs-to-hash (row-to-result row 'PAIRS)))
        ((eq result-type 'HASH) (array-to-hash (row-to-result row 'ARRAY)))
        ((eq result-type 'PAIRS)
         (let ((colinfo (oracle_column_info (curconn))))
           (check-success)
           (cond
            ((null row) nil)
            (t (map 'list
                    #'(lambda (col rowval)
                        (list (sqlcol-name col) rowval))
                    colinfo row)))))
        (t (error (cat "Invalid result type '" result-type "' given - should be 'ARRAY, 'PAIRS or 'HASH")))))


; CHECK-SUCCESS
; Check Oracle success code after calling a function.  Assumes (check-connection) was called!
(defun check-success ()
  (if (not (lisp-truth (oracle_success (curconn))))
      (error (oracle_last_error (curconn))))
  t)

; Convert Oracle type based on sqlcol data type.  Oracle numerics are converted
; to the appropriate internal Lisp type using READ-FROM-STRING.  NULL is retained
; as Lisp NIL, and strings and dates are left as Lisp string.
(defun convert-type (val sc)
  (let ((dtype (sqlcol-type sc)))
    (cond ((null val) nil)
          ((find dtype '("NUMBER" "INTEGER" "FLOAT") :test #'equal)
           (read-from-string val))
          ((find dtype '("VARCHAR" "DATE" "CHAR" "VARCHAR2") :test #'equal)
           val)
          (t (error (cat "Unsupported data type '" dtype "'"))))))

; TO-SQLVAL
; Return a SQL val for LISP object, handling null case
(defun to-sqlval (x)
  (if (null x)
      (make-sqlval :data "" :is_null 1)
    (make-sqlval :data (to-string x) :is_null 0)))

; FROM-SQLVAL
; Return Lisp Object (string or NIL) for SQL val, handling null case
(defun from-sqlval (x)
  (if (lisp-truth (sqlval-is_null x))
      nil
    (sqlval-data x)))

; ROWVAL
; Return string value of an SQLVAL (row value), or "" if null
(defun rowval (row) (if (= 0 (sqlval-is_null row))
                        (sqlval-data row)
                      nil))

; HASH-TO-SQLPARAM-ARRAY
; Convert a hash table map of name->value strings to an array of SQL
; bind params suitable for passing to ORACLE_EXEC_SQL
(defun hash-to-sqlparam-array (h)
  (if (null h) (setf h (make-hash-table :test #'equal)))
  (let* ((count (hash-table-count h))
         (result (make-array count))
         (i 0))
    (loop for key being the hash-keys of h do
          (let ((val (gethash key h)))
            (when (not (atom key))
                  (error "Non-atom parameter name in bind-parameter hash"))
            (when (not (atom val))
                  (error "Non-atom parameter value in bind-parameter hash"))
            (setf (aref result i) (make-sqlparam :name (to-string key) :value (to-sqlval val)))
            (incf i)))
    result))

; CHECK-CONNECTION
; Check we are connected before doing an operation that requires a connection
(defun check-connection (&optional action)
  (if (null (curconn))
      (error (cat "Attempt to "
                  (if-null action "perform database operation")
                  " when not connected to any database"))))

; CONNECTION-KEY
; Construct key suitable for use in hash table keyed on
; unique triple of (user, schema, server)
(defun connection-key (user schema server)
  ; Use ~-delimited string - pretty disgusting, eh?
  (cat (string-upcase user) "~" (string-upcase schema) "~" (string-upcase server)))

; PAIRS-TO-HASH
; Convert a list of pairs ((key1 val1) (key2 val2) ...) to hash, enforcing key uniqueness
(defun pairs-to-hash (plist)
  (if (null plist)
      nil
    (let ((result (make-hash-table :test #'equal)))
      (loop for p in plist do
            (let ((key (string-upcase (to-string (first p))))
                  (value (second p)))
              (when (not (valid-symbol key)) (error (cat "Column or parameter '" key "' is not a valid Lisp symbol name."
                                                         "~%Consider using SELECT ... " key " AS <column alias>")))
              ; Check uniqueness
              (multiple-value-bind 
               (curval already-there) (gethash key result)
               (when already-there (error (cat "Column or parameter '" key
                                               "' appears twice in list of (name, value) pairs,~%first with value '"
                                               curval "' and again with value '" value "'.  Columns/parameters given were:~%"
                                               (join "~%" (map 'list #'car plist))
                                               (nl)))))
              (setf (gethash key result) value)))
      result)))


; CHECK-PAIRS
; Convert pairs to hash if needed
(defun check-pairs (p)
  (cond ((null p) (make-hash-table :test #'equal))
        ((eq (type-of p) 'HASH-TABLE) p)
        ((eq (type-of p) 'CONS) (pairs-to-hash p))
        (t (error (cat "Invalid type for name -> value map: '" (type-of p) "' - should be hash or list of pairs.")))))

; COMMA-LIST-OF-KEYS
; Return keys of hash table as comma-separated list.  If flag given,
; also pre-pend a colon to the name
(defun comma-list-of-keys (h &optional (colon nil))
  (let ((result "")
        (plural nil))
    (loop for hkey being each hash-key of h do
          (if plural
              (setf result (cat result ", "))
            (setf plural t))
          (when colon (setf result (cat result ":")))
          (setf result (cat result hkey)))
    result))

; IS-SELECT-QUERY
; Examine string to see if it begins with "SELECT".  Useful to auto-detect
; the mode (SELECT vs. non-SELECT for executing statements.
(defun is-select-query (s)
  (let ((start (string-trim '(#\Space #\Tab #\Newline) (string-upcase s))))
    (equal "SELECT" (subseq start 0 6))))

; =-=-=-=-=-=-=-   C WRAPPER FUNCTIONS  =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

; CONNECT
(def-call-out oracle_connect (:arguments (user           c-string)
                                         (schema         c-string)
                                         (password       c-string)
                                         (server         c-string)
                                         (prefetch_bytes int)
                                         (auto_commit    int))
                             (:return-type c-pointer))

; DISCONNECT
(def-call-out oracle_disconnect (:arguments (db c-pointer))
                                (:return-type int  ))

; RUN SQL
(def-call-out oracle_exec_sql (:arguments (db         c-pointer)
                                          (sql        c-string)
                                          (params     (c-array-ptr (c-ptr sqlparam)))
                                          (is_command int))
                              (:return-type int))

; NO. OF COLUMNS
(def-call-out oracle_ncol (:arguments (db c-pointer))
                          (:return-type int))

; COLUMN INFO
(def-call-out oracle_column_info (:arguments (db c-pointer))
                                 (:return-type (c-array-ptr (c-ptr sqlcol))))

; FETCH
(def-call-out oracle_fetch_row (:arguments (db c-pointer))
                               (:return-type int))

; EOF
(def-call-out oracle_eof (:arguments (db c-pointer))
                         (:return-type int))

; SUCCESS
(def-call-out oracle_success (:arguments (db c-pointer))
                             (:return-type int))

; ROW VALUES
(def-call-out oracle_row_values (:arguments (db c-pointer))
                                (:return-type (c-array-ptr (c-ptr sqlval))))

; NO. ROWS AFFECTED
(def-call-out oracle_rows_affected (:arguments (db c-pointer))
                                   (:return-type int))

; COMMIT
(def-call-out oracle_commit (:arguments (db c-pointer))
                            (:return-type int))

(def-call-out oracle_rollback (:arguments (db c-pointer))
                              (:return-type int))

(def-call-out oracle_set_auto_commit (:arguments (db c-pointer)
                                                 (auto_commit int))
                                     (:return-type int))

; ERROR
(def-call-out oracle_last_error (:arguments (db c-pointer))
                                (:return-type c-string))


; =-=-=-=-=-=-=-   LOW LEVEL UTILITY FUNCTIONS  =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

; IF-NULL
; Default a null value.  Is there a better Lisp built-in for this?
(defun if-null (value default) (if (null value) default value))

; AREF-NULL
; Do an AREF, but allow array to be null, in which case return NIL
(defun aref-null (a i) (if (null a) nil (aref a i)))

; HASH-COMBINE
; Combine two hash table.  Keys of the second hash will overwrite.
(defun hash-combine (h1 h2)
  (cond ((null h1) h2)
        ((null h2) h1)
        (t (loop for hkey being each hash-key of h2 do
                 (setf (gethash hkey h1)
                       (gethash hkey h2)))
           h1)))

; VALID-SYMBOL
; Test whether string is a valid Lisp symbol name
(defun valid-symbol (x)
  (equal (string-upcase (to-string x))
         (to-string (read-from-string x))))

; TO-STRING
; Convert object to a string; NIL -> ""
(defun to-string (s)
  (cond ((null s) "")
        ((stringp s) s)
        ((symbolp s) (symbol-name s))
        (t (format nil "~A" s))))

; CAT
; Concatenate strings
(defun cat (&rest args) 
  (apply #'concatenate 'string (mapcar #'to-string (flatten args))))

; ARRAY-TO-HASH
; Convert array of row values to hash using column info
(defun array-to-hash (row)
  (if (null row)
      nil
    (let* ((cols (columns))
           (n (length row))
           (result (make-hash-table :test #'equal :size n)))
      (loop for i from 0 to (- n 1) do
            (setf (gethash (to-string (sqlcol-name (aref cols i))) result) (aref row i)))
      result)))

; CHECK-UNIQUE-ELEMENTS
; Does list consist of unqiue, non-null elements
(defun check-unique-elements (l)
  (let ((h (make-hash-table :test #'equal)))
    (dolist (elt l)
            (when (null elt)
                  (error "Null element in column/variable list"))
            (when (gethash (to-string elt) h)
                  (error (cat "DO-ROWS: Parameter/column '" elt "' occurs more than once in bound columns/variables:~%"
                              (join "~%" l))))
            (setf (gethash (to-string elt) h) t))
    t))

; JOIN
; Join a sequence of strings into one, separating with delimeter
; I'll probably get shot for this implementation.  Better way?
(defun join (delimiter seq)
  (let ((result ""))
    (loop for i from 0 to (- (length seq) 1) do
          (when (> i 0)
                (setf result (cat result delimiter)))
          (setf result (cat result (nth i seq))))
    result))

; WHILE (macro)
; While loop construct (lifted from Paul Graham)
(defmacro while (test &body body)
  `(do ()
       ((not ,test))
     ,@body))

; OUT
; Output functions
(defun out (&rest args)
  (format t "~A" (cat args)))
; OUT-NL
(defun out-nl (&rest args)
  (out args)
  (terpri))

; LISP-TRUTH
; Get Lisp truth of object, considering "C" 0/1 also.  Useful for
; taking booleans returned from "C"
(defun lisp-truth (x)
  (if (eq x 0) nil (not (null x))))

; C-TRUTH
; Get "C" truth of object (0 or 1).  Useful for passing args to "C"
(defun c-truth (x)
  (if (lisp-truth x) 1 0))

; FLATTEN
; Flatten list (lifted from Paul Graham)
(defun flatten (x)
  (labels ((rec (x acc)
             (cond ((null x) acc)
                   ((atom x) (cons x acc))
                   (t (rec (car x) (rec (cdr x) acc))))))
    (rec x nil)))

; NL
; Return newline
(defun nl () (format nil "~%"))

; End of oracle.lisp