build-stamp
*~
*.fasl
+#*#
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: clsql-postgresql-socket.asd
+;;;; Purpose: ASDF file for CLSQL PostgresSQL socket (protocol vs 3) backend
+;;;; Programmer: Russ Tyndall
+;;;; Date Started: Sept 2009
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; 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.
+;;;; *************************************************************************
+
+(defpackage #:clsql-postgresql-socket-system (:use #:asdf #:cl))
+(in-package #:clsql-postgresql-socket-system)
+
+;;; System definition
+
+(defsystem clsql-postgresql-socket3
+ :name "cl-sql-postgresql-socket3"
+ :author "Russ Tyndall <russ@acceleration.net>"
+ :maintainer "Russ Tyndall <russ@acceleration.net>"
+ :licence "Lessor Lisp General Public License"
+ :description "Common Lisp SQL PostgreSQL Socket Driver"
+ :long-description "cl-sql-postgresql-socket package provides a database driver to the PostgreSQL database via a socket interface."
+
+ :depends-on (clsql md5 :cl-postgres #+sbcl sb-bsd-sockets)
+ :components
+ ((:module :db-postgresql-socket3
+ :serial T
+ :components ((:file "package")
+ (:file "api")
+ (:file "sql")))))
(:file "test-ooddl")
(:file "test-oodml")
(:file "test-syntax")
+ (:file "test-pool")
; #-uffi:no-i18n (:file "test-i18n")
))))
:pathname ""
:components ((:file "generic-postgresql")
(:file "generic-odbc")
- (:file "sequences"))
+ (:file "sequences")
+ (:file "command-object"))
:depends-on (functional))))))
(defpackage #:clsql-mysql
(:use #:common-lisp #:clsql-sys #:mysql #:clsql-uffi)
(:export #:mysql-database)
+ (:import-from :clsql-sys
+ :escaped :unescaped :combine-database-identifiers
+ :escaped-database-identifier :unescaped-database-identifier :database-identifier
+ :%sequence-name-to-table :%table-name-to-sequence-name)
(:documentation "This is the CLSQL interface to MySQL."))
(in-package #:clsql-mysql)
(declare (ignore owner))
(do ((results nil)
(rows (database-query
- (format nil "SHOW INDEX FROM ~A" table)
+ (format nil "SHOW INDEX FROM ~A" (escaped-database-identifier
+ table database))
database nil nil)
(cdr rows)))
((null rows) (nreverse results))
(declare (ignore owner))
(mapcar #'car
(database-query
- (format nil "SHOW COLUMNS FROM ~A" table)
+ (format nil "SHOW COLUMNS FROM ~A" (escaped-database-identifier
+ table database))
database nil nil)))
(defmethod database-attribute-type (attribute (table string)
(declare (ignore owner))
(let ((row (car (database-query
(format nil
- "SHOW COLUMNS FROM ~A LIKE '~A'" table attribute)
+ "SHOW COLUMNS FROM ~A LIKE '~A'"
+ (escaped-database-identifier
+ table database)
+ (unescaped-database-identifier
+ attribute database))
database nil nil))))
(let* ((raw-type (second row))
(null (third row))
;;; Sequence functions
-(defun %sequence-name-to-table (sequence-name)
- (concatenate 'string "_CLSQL_SEQ_" (sql-escape sequence-name)))
-
-(defun %table-name-to-sequence-name (table-name)
- (and (>= (length table-name) 11)
- (string-equal (subseq table-name 0 11) "_CLSQL_SEQ_")
- (subseq table-name 11)))
-
(defmethod database-create-sequence (sequence-name
(database mysql-database))
- (let ((table-name (%sequence-name-to-table sequence-name)))
+ (let ((table-name (%sequence-name-to-table sequence-name database)))
(database-execute-command
(concatenate 'string "CREATE TABLE " table-name
" (id int NOT NULL PRIMARY KEY AUTO_INCREMENT)")
(defmethod database-drop-sequence (sequence-name
(database mysql-database))
(database-execute-command
- (concatenate 'string "DROP TABLE " (%sequence-name-to-table sequence-name))
+ (concatenate 'string "DROP TABLE "
+ (%sequence-name-to-table sequence-name database))
database))
(defmethod database-list-sequences ((database mysql-database)
(declare (ignore owner))
(mapcan #'(lambda (s)
(let ((sn (%table-name-to-sequence-name (car s))))
- (and sn (list sn))))
+ (and sn (list (car s) sn))))
(database-query "SHOW TABLES" database nil nil)))
(defmethod database-set-sequence-position (sequence-name
(position integer)
(database mysql-database))
(database-execute-command
- (format nil "UPDATE ~A SET id=~A" (%sequence-name-to-table sequence-name)
+ (format nil "UPDATE ~A SET id=~A" (%sequence-name-to-table sequence-name database)
position)
database)
(mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database)))
(defmethod database-sequence-next (sequence-name (database mysql-database))
(without-interrupts
(database-execute-command
- (concatenate 'string "UPDATE " (%sequence-name-to-table sequence-name)
+ (concatenate 'string "UPDATE " (%sequence-name-to-table sequence-name database)
" SET id=LAST_INSERT_ID(id+1)")
database)
(mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database))))
(without-interrupts
(caar (database-query
(concatenate 'string "SELECT id from "
- (%sequence-name-to-table sequence-name))
+ (%sequence-name-to-table sequence-name database))
database :auto nil))))
(defmethod database-last-auto-increment-id ((database mysql-database) table column)
(defun %cstring-into-vector (ptr vector offset size-in-bytes)
(dotimes (i size-in-bytes)
(setf (schar vector offset)
- (ensure-char-character
- (deref-array ptr '(:array :unsigned-char) i)))
+ (ensure-char-character
+ ;; this is MUCH faster than (sb-alien:deref ptr i) even though
+ ;; sb-alien:deref makes more sense. I snagged this by looking at
+ ;; cffi which we had used previously without this bug
+ #+(and sbcl (not cffi))
+ (sb-sys:sap-ref-8 (sb-alien:alien-sap ptr) i)
+ #-(and sbcl (not cffi))
+ (deref-array ptr '(:array :unsigned-char) i)
+ ))
(incf offset))
offset)
(defun read-data (data-ptr c-type sql-type out-len-ptr result-type)
(declare (type long-ptr-type out-len-ptr))
- (let* ((out-len (deref-pointer out-len-ptr #.$ODBC-LONG-TYPE))
+ (let* ((out-len (get-cast-long out-len-ptr))
(value
- (cond ((= out-len $SQL_NULL_DATA)
- *null*)
+ (cond ((= out-len $SQL_NULL_DATA) *null*)
(t
(case sql-type
;; SQL extended datatypes
(#.$SQL_SMALLINT (get-cast-short data-ptr)) ;; ??
(#.$SQL_INTEGER (get-cast-int data-ptr))
(#.$SQL_BIGINT (get-cast-big data-ptr))
- (#.$SQL_DECIMAL
- (let ((*read-base* 10))
- (read-from-string (get-cast-foreign-string data-ptr))))
+ ;; TODO: Change this to read in rationals instead of doubles
+ ((#.$SQL_DECIMAL #.$SQL_NUMERIC)
+ (let* ((*read-base* 10)
+ (*read-default-float-format* 'double-float)
+ (str (get-cast-foreign-string data-ptr)))
+ (read-from-string str)))
(#.$SQL_BIT (get-cast-byte data-ptr))
(t
(case c-type
(defconstant $sql-data-truncated (intern "01004" :keyword))
+
(defun read-data-in-chunks (hstmt column-nr data-ptr c-type sql-type
out-len-ptr result-type)
(declare (type long-ptr-type out-len-ptr)
(ignore result-type))
(let* ((res (%sql-get-data hstmt column-nr c-type data-ptr
+max-precision+ out-len-ptr))
- (out-len (deref-pointer out-len-ptr #.$ODBC-LONG-TYPE))
+ (out-len (get-cast-long out-len-ptr))
(offset 0)
(result (case out-len
(#.$SQL_NULL_DATA
(let ((*read-base* 10))
(read-from-string str))
str)))
- (otherwise
- (let ((str)
- (offset 0)
- (octets (make-array out-len :element-type '(unsigned-byte 8) :initial-element 0)))
+ (otherwise
+ (let ((str (make-string out-len)))
(loop
- do
- (loop for i from 0 to (1- (min out-len +max-precision+))
- do (setf (aref octets (+ offset i)) (deref-array data-ptr '(:array :unsigned-byte) i))
- finally (incf offset (1- i)))
- while
- (and (= res $SQL_SUCCESS_WITH_INFO)
- (> out-len +max-precision+))
- do
- (setf res (%sql-get-data hstmt column-nr c-type data-ptr +max-precision+ out-len-ptr)
- out-len (deref-pointer out-len-ptr #.$ODBC-LONG-TYPE)))
- (setf str (uffi:octets-to-string octets))
+ do
+ (if (= c-type #.$SQL_CHAR)
+ (setf offset (%cstring-into-vector ;string
+ data-ptr str
+ offset
+ (min out-len (1- +max-precision+))))
+ (error 'clsql:sql-database-error :message "wrong type. preliminary."))
+ while
+ (and (= res $SQL_SUCCESS_WITH_INFO)
+ (>= out-len +max-precision+))
+ do (setf res (%sql-get-data hstmt column-nr c-type data-ptr
+ +max-precision+ out-len-ptr)
+ out-len (get-cast-long out-len-ptr)))
(if (= sql-type $SQL_DECIMAL)
- (let ((*read-base* 10))
+ (let ((*read-base* 10)
+ (*read-default-float-format* 'double-float))
(read-from-string str))
str))))))
+
(setf (deref-pointer out-len-ptr #.$ODBC-LONG-TYPE) #.$SQL_NO_TOTAL) ;; reset the out length for the next row
result))
+
(def-type c-timestamp-ptr-type (* (:struct sql-c-timestamp)))
(def-type c-time-ptr-type (* (:struct sql-c-time)))
(def-type c-date-ptr-type (* (:struct sql-c-date)))
(cond ((< 0 precision (query-width query))
(read-data data-ptr c-type sql-type out-len-ptr result-type))
((zerop (get-cast-long out-len-ptr))
- nil)
+ nil)
(t
(read-data-in-chunks hstmt j data-ptr c-type sql-type
out-len-ptr result-type))))))))
;; get column information
(initialize-column col-nr))))
+ ;; TODO: move this into the above loop
(setf computed-result-types (make-array column-count))
(dotimes (i column-count)
(setf (aref computed-result-types i)
(#.odbc::$SQL_C_STINYINT :short)
(#.odbc::$SQL_C_SBIGINT #.odbc::$ODBC-BIG-TYPE)
(#.odbc::$SQL_C_TYPE_TIMESTAMP :time)
+ (#.odbc::$SQL_C_CHAR ;; TODO: Read this as rational instead of double
+ (or (case (aref column-sql-types i)
+ (#.odbc::$SQL_NUMERIC :double))
+ T))
+
(t t)))
(t t)))))
query)
(defmethod database-name-from-spec (connection-spec
(database-type (eql :odbc)))
- (check-connection-spec connection-spec database-type (dsn user password &key connection-string completion window-handle))
+ (check-connection-spec connection-spec database-type
+ (dsn user password &key connection-string completion window-handle))
(destructuring-bind (dsn user password &key connection-string completion window-handle) connection-spec
(declare (ignore password connection-string completion window-handle))
(concatenate 'string dsn "/" user)))
(defmethod database-connect (connection-spec (database-type (eql :odbc)))
- (check-connection-spec connection-spec database-type (dsn user password &key connection-string completion window-handle))
+ (check-connection-spec connection-spec database-type
+ (dsn user password &key connection-string completion window-handle))
(destructuring-bind (dsn user password &key connection-string (completion :no-prompt) window-handle) connection-spec
(handler-case
(let ((db (make-instance 'odbc-database
--- /dev/null
+clsql-uffi.so
+clsql-uffi.dll
+clsql-uffi.lib
+clsql-uffi.dylib
+.bin
+*.fasl
+*.pfsl
+*.dfsl
+*.cfsl
+*.fasla16
+*.fasla8
+*.faslm16
+*.faslm8
+*.fsl
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: postgresql-socket-api.lisp
+;;;; Purpose: Low-level PostgreSQL interface using sockets
+;;;; Authors: Kevin M. Rosenberg based on original code by Pierre R. Mai
+;;;; Created: Feb 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg
+;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
+;;;;
+;;;; 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 #:postgresql-socket3)
+
+(defmethod clsql-sys:database-type-load-foreign ((database-type (eql :postgresql-socket3)))
+ t)
+
+(defmethod clsql-sys:database-type-library-loaded ((database-type
+ (eql :postgresql-socket3)))
+ "T if foreign library was able to be loaded successfully. Always true for
+socket interface"
+ t)
+
+(defparameter +postgresql-server-default-port+ 5432
+ "Default port of PostgreSQL server.")
+
+;;;; Condition hierarchy
+
+(define-condition postgresql-condition (condition)
+ ((connection :initarg :connection :reader postgresql-condition-connection)
+ (message :initarg :message :reader postgresql-condition-message))
+ (:report
+ (lambda (c stream)
+ (format stream "~@<~A occurred on connection ~A. ~:@_Reason: ~A~:@>"
+ (type-of c)
+ (postgresql-condition-connection c)
+ (postgresql-condition-message c)))))
+
+(define-condition postgresql-error (error postgresql-condition)
+ ())
+
+(define-condition postgresql-fatal-error (postgresql-error)
+ ())
+
+(define-condition postgresql-login-error (postgresql-fatal-error)
+ ())
+
+(define-condition postgresql-warning (warning postgresql-condition)
+ ())
+
+(define-condition postgresql-notification (postgresql-condition)
+ ()
+ (:report
+ (lambda (c stream)
+ (format stream "~@<Asynchronous notification on connection ~A: ~:@_~A~:@>"
+ (postgresql-condition-connection c)
+ (postgresql-condition-message c)))))
\ No newline at end of file
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: postgresql-socket-package.lisp
+;;;; Purpose: Package definition for PostgreSQL interface using sockets
+;;;; Programmers: Kevin M. Rosenberg
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; 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 #:cl-user)
+
+#+lispworks (require "comm")
+
+(defpackage #:postgresql-socket3
+ (:use #:cl md5 #:cl-postgres)
+ (:shadow #:postgresql-warning)
+ (:export #:+postgresql-server-default-port+
+ #:postgresql-condition
+ #:postgresql-error
+ #:postgresql-fatal-error
+ #:postgresql-login-error
+ #:postgresql-warning
+ #:postgresql-notification
+ #:postgresql-condition-message
+ #:postgresql-condition-connection))
+
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: postgresql-socket-sql.sql
+;;;; Purpose: High-level PostgreSQL interface using socket
+;;;; Authors: Kevin M. Rosenberg based on original code by Pierre R. Mai
+;;;; Created: Feb 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of CLSQL, is Copyright (c) 2002-2007 by Kevin M. Rosenberg
+;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
+;;;;
+;;;; 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 #:cl-user)
+
+(defpackage :clsql-postgresql-socket3
+ (:use #:common-lisp #:clsql-sys #:postgresql-socket3)
+ (:export #:postgresql-socket3-database)
+ (:documentation "This is the CLSQL socket interface (protocol version 3) to PostgreSQL."))
+
+(in-package #:clsql-postgresql-socket3)
+
+(defvar *sqlreader* (cl-postgres:copy-sql-readtable))
+(let ((dt-fn (lambda (useconds-since-2000)
+ (let ((sec (truncate
+ (/ useconds-since-2000
+ 1000000)))
+ (usec (mod useconds-since-2000
+ 1000000)))
+ (clsql:make-time :year 2000 :second sec :usec usec)))))
+ (cl-postgres:set-sql-datetime-readers
+ :table *sqlreader*
+ :date (lambda (days-since-2000)
+ (clsql:make-date :year 2000 :day (+ 1 days-since-2000)))
+ :timestamp dt-fn
+ :timestamp-with-timezone dt-fn))
+
+
+
+;; interface foreign library loading routines
+
+(clsql-sys:database-type-load-foreign :postgresql-socket3)
+
+
+(defmethod database-initialize-database-type ((database-type
+ (eql :postgresql-socket3)))
+ t)
+
+
+;; Field type conversion
+(defun convert-to-clsql-warning (database condition)
+ (ecase *backend-warning-behavior*
+ (:warn
+ (warn 'sql-database-warning :database database
+ :message (cl-postgres:database-error-message condition)))
+ (:error
+ (error 'sql-database-error :database database
+ :message (format nil "Warning upgraded to error: ~A"
+ (cl-postgres:database-error-message condition))))
+ ((:ignore nil)
+ ;; do nothing
+ )))
+
+(defun convert-to-clsql-error (database expression condition)
+ (error 'sql-database-data-error
+ :database database
+ :expression expression
+ :error-id (type-of condition)
+ :message (cl-postgres:database-error-message condition)))
+
+(defmacro with-postgresql-handlers
+ ((database &optional expression)
+ &body body)
+ (let ((database-var (gensym))
+ (expression-var (gensym)))
+ `(let ((,database-var ,database)
+ (,expression-var ,expression))
+ (handler-bind ((postgresql-warning
+ (lambda (c)
+ (convert-to-clsql-warning ,database-var c)))
+ (cl-postgres:database-error
+ (lambda (c)
+ (convert-to-clsql-error
+ ,database-var ,expression-var c))))
+ ,@body))))
+
+
+
+(defclass postgresql-socket3-database (generic-postgresql-database)
+ ((connection :accessor database-connection :initarg :connection
+ :type cl-postgres:database-connection)))
+
+(defmethod database-type ((database postgresql-socket3-database))
+ :postgresql-socket3)
+
+(defmethod database-name-from-spec (connection-spec (database-type (eql :postgresql-socket3)))
+ (check-connection-spec connection-spec database-type
+ (host db user password &optional port options tty))
+ (destructuring-bind (host db user password &optional port options tty)
+ connection-spec
+ (declare (ignore password options tty))
+ (concatenate 'string
+ (etypecase host
+ (null
+ "localhost")
+ (pathname (namestring host))
+ (string host))
+ (when port
+ (concatenate 'string
+ ":"
+ (etypecase port
+ (integer (write-to-string port))
+ (string port))))
+ "/" db "/" user)))
+
+(defmethod database-connect (connection-spec
+ (database-type (eql :postgresql-socket3)))
+ (check-connection-spec connection-spec database-type
+ (host db user password &optional port options tty))
+ (destructuring-bind (host db user password &optional
+ (port +postgresql-server-default-port+)
+ (options "") (tty ""))
+ connection-spec
+ (declare (ignore options tty))
+ (handler-case
+ (handler-bind ((warning
+ (lambda (c)
+ (warn 'sql-warning
+ :format-control "~A"
+ :format-arguments
+ (list (princ-to-string c))))))
+ (cl-postgres:open-database db user password host port))
+ (cl-postgres:database-error (c)
+ ;; Connect failed
+ (error 'sql-connection-error
+ :database-type database-type
+ :connection-spec connection-spec
+ :error-id (type-of c)
+ :message (cl-postgres:database-error-message c)))
+ (:no-error (connection)
+ ;; Success, make instance
+ (make-instance 'postgresql-socket3-database
+ :name (database-name-from-spec connection-spec database-type)
+ :database-type :postgresql-socket3
+ :connection-spec connection-spec
+ :connection connection)))))
+
+(defmethod database-disconnect ((database postgresql-socket3-database))
+ (cl-postgres:close-database (database-connection database))
+ t)
+
+(defvar *include-field-names* nil)
+
+
+;; THE FOLLOWING MACRO EXPANDS TO THE FUNCTION BELOW IT,
+;; BUT TO GET null CONVENTIONS CORRECT I NEEDED TO TWEAK THE EXPANSION
+;;
+;; (cl-postgres:def-row-reader clsql-default-row-reader (fields)
+;; (values (loop :while (cl-postgres:next-row)
+;; :collect (loop :for field :across fields
+;; :collect (cl-postgres:next-field field)))
+;; (when *include-field-names*
+;; (loop :for field :across fields
+;; :collect (cl-postgres:field-name field)))))
+
+
+
+(defun clsql-default-row-reader (stream fields)
+ (declare (type stream stream)
+ (type (simple-array cl-postgres::field-description) fields))
+ (flet ((cl-postgres:next-row ()
+ (cl-postgres::look-for-row stream))
+ (cl-postgres:next-field (cl-postgres::field)
+ (declare (type cl-postgres::field-description cl-postgres::field))
+ (let ((cl-postgres::size (cl-postgres::read-int4 stream)))
+ (declare (type (signed-byte 32) cl-postgres::size))
+ (if (eq cl-postgres::size -1)
+ nil
+ (funcall (cl-postgres::field-interpreter cl-postgres::field)
+ stream cl-postgres::size)))))
+ (let ((results (loop :while (cl-postgres:next-row)
+ :collect (loop :for field :across fields
+ :collect (cl-postgres:next-field field))))
+ (col-names (when *include-field-names*
+ (loop :for field :across fields
+ :collect (cl-postgres:field-name field)))))
+ ;;multiple return values were not working here
+ (list results col-names))))
+
+(defmethod database-query ((expression string) (database postgresql-socket3-database) result-types field-names)
+ (let ((connection (database-connection database))
+ (cl-postgres:*sql-readtable* *sqlreader*))
+ (with-postgresql-handlers (database expression)
+ (let ((*include-field-names* field-names))
+ (apply #'values (cl-postgres:exec-query connection expression #'clsql-default-row-reader)))
+ )))
+
+(defmethod query ((obj command-object) &key (database *default-database*)
+ (result-types :auto) (flatp nil) (field-names t))
+ (clsql-sys::record-sql-command
+ (format nil "~&~A~&{Params: ~{~A~^, ~}}"
+ (expression obj)
+ (parameters obj))
+ database)
+ (multiple-value-bind (rows names)
+ (database-query obj database result-types field-names)
+ (let ((result (if (and flatp (= 1 (length (car rows))))
+ (mapcar #'car rows)
+ rows)))
+ (clsql-sys::record-sql-result result database)
+ (if field-names
+ (values result names)
+ result))))
+
+(defmethod database-query ((obj command-object) (database postgresql-socket3-database) result-types field-names)
+ (let ((connection (database-connection database))
+ (cl-postgres:*sql-readtable* *sqlreader*))
+ (with-postgresql-handlers (database obj)
+ (let ((*include-field-names* field-names))
+ (unless (has-been-prepared obj)
+ (cl-postgres:prepare-query connection (prepared-name obj) (expression obj))
+ (setf (has-been-prepared obj) T))
+ (apply #'values (cl-postgres:exec-prepared
+ connection
+ (prepared-name obj)
+ (parameters obj)
+ #'clsql-default-row-reader))))))
+
+(defmethod database-execute-command
+ ((expression string) (database postgresql-socket3-database))
+ (let ((connection (database-connection database)))
+ (with-postgresql-handlers (database expression)
+ ;; return row count?
+ (second (multiple-value-list (cl-postgres:exec-query connection expression))))))
+
+(defmethod execute-command ((obj command-object)
+ &key (database *default-database*))
+ (clsql-sys::record-sql-command (expression obj) database)
+ (let ((res (database-execute-command obj database)))
+ (clsql-sys::record-sql-result res database)
+ ;; return row count?
+ res))
+
+(defmethod database-execute-command
+ ((obj command-object) (database postgresql-socket3-database))
+ (let ((connection (database-connection database)))
+ (with-postgresql-handlers (database obj)
+ (unless (has-been-prepared obj)
+ (cl-postgres:prepare-query connection (prepared-name obj) (expression obj))
+ (setf (has-been-prepared obj) T))
+ (second (multiple-value-list (cl-postgres:exec-prepared connection (prepared-name obj) (parameters obj)))))))
+
+;;;; Cursoring interface
+
+
+(defmethod database-query-result-set ((expression string)
+ (database postgresql-socket3-database)
+ &key full-set result-types)
+ (declare (ignore result-types))
+ (declare (ignore full-set))
+ (error "Cursoring interface is not supported for postgresql-socket3-database try cl-postgres:exec-query with a custom row-reader"))
+
+(defmethod database-dump-result-set (result-set
+ (database postgresql-socket3-database))
+ (error "Cursoring interface is not supported for postgresql-socket3-database try cl-postgres:exec-query with a custom row-reader")
+ T)
+
+(defmethod database-store-next-row (result-set
+ (database postgresql-socket3-database)
+ list)
+ (error "Cursoring interface is not supported for postgresql-socket3-database try cl-postgres:exec-query with a custom row-reader"))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(defmethod database-create (connection-spec (type (eql :postgresql-socket3)))
+ (destructuring-bind (host name user password &optional port options tty) connection-spec
+ (declare (ignore port options tty))
+ (let ((database (database-connect (list host "postgres" user password)
+ type)))
+ (setf (slot-value database 'clsql-sys::state) :open)
+ (unwind-protect
+ (database-execute-command (format nil "create database ~A" name) database)
+ (database-disconnect database)))))
+
+(defmethod database-destroy (connection-spec (type (eql :postgresql-socket3)))
+ (destructuring-bind (host name user password &optional port options tty) connection-spec
+ (declare (ignore port options tty))
+ (let ((database (database-connect (list host "postgres" user password)
+ type)))
+ (setf (slot-value database 'clsql-sys::state) :open)
+ (unwind-protect
+ (database-execute-command (format nil "drop database ~A" name) database)
+ (database-disconnect database)))))
+
+
+(defmethod database-probe (connection-spec (type (eql :postgresql-socket3)))
+ (when (find (second connection-spec) (database-list connection-spec type)
+ :test #'string-equal)
+ t))
+
+
+;; Database capabilities
+
+(defmethod db-backend-has-create/destroy-db? ((db-type (eql :postgresql-socket3)))
+ nil)
+
+(defmethod db-type-has-fancy-math? ((db-type (eql :postgresql-socket3)))
+ t)
+
+(defmethod db-type-default-case ((db-type (eql :postgresql-socket3)))
+ :lower)
+
+(defmethod database-underlying-type ((database postgresql-socket3-database))
+ :postgresql)
+
+(when (clsql-sys:database-type-library-loaded :postgresql-socket3)
+ (clsql-sys:initialize-database-type :database-type :postgresql-socket3))
+
+
+;; Type munging functions
+
+(defmethod read-sql-value (val (type (eql 'boolean)) (database postgresql-socket3-database) db-type)
+ (declare (ignore database db-type))
+ val)
+
+(defmethod read-sql-value (val (type (eql 'generalized-boolean)) (database postgresql-socket3-database) db-type)
+ (declare (ignore database db-type))
+ val)
</refsect1>
<refsect1>
<title>Description</title>
- <para>Threshold of free-connections in the pool before we disconnect a
- database rather than returning it to the pool. This is really a heuristic
-that should, on avg keep the free connections about this size.</para>
+ <para>Threshold of free-connections in the pool before we
+ disconnect a database rather than returning it to the pool. NIL for
+ no limit. This is really a heuristic that should, on avg keep the
+ free connections about this size.</para>
<note>
<para>This is not a hard limit, the number of connections in
the pool may exceed this value.</para>
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: postgresql-socket-sql.sql
+;;;; Purpose: High-level PostgreSQL interface using socket
+;;;; Authors: Russ Tyndall (at Acceleration.net) based on original code by
+;;;; Kevin M. Rosenberg based on original code by Pierre R. Mai
+;;;; Created: Sep 2009
+;;;;
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of CLSQL, is Copyright (c) 2002-2007 by Kevin M. Rosenberg
+;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
+;;;;
+;;;; 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-sys)
+
+(defclass command-object ()
+ ((expression :accessor expression :initarg :expression :initform nil)
+ (parameters :accessor parameters :initarg :parameters :initform nil)
+ (prepared-name :accessor prepared-name :initarg :prepared-name :initform ""
+ :documentation "If we want this to be a prepared statement, give it a name
+ to identify it to this session")
+ (has-been-prepared :accessor has-been-prepared :initarg :has-been-prepared :initform nil
+ :documentation "Have we already prepared this command object")
+ ))
+
+(defmethod initialize-instance :after ((o command-object) &key &allow-other-keys )
+ ;; Inits parameter nulls
+ (setf (parameters o) (parameters o)))
+
+(defmethod (setf parameters) (new (o command-object))
+ " This causes the semantics to match cl-sql instead of cl-postgresql
+ "
+ (setf (slot-value o 'parameters)
+ (loop for p in new
+ collecting (cond ((null p) :null)
+ ((member p (list :false :F)) nil)
+ (T p)))))
+
+(defun reset-command-object (co)
+ "Resets the command object to have no name and to be unprepared
+ (This is useful if you want to run a command against a second database)"
+ (setf (prepared-name co) ""
+ (has-been-prepared co) nil))
+
+(defun command-object (expression &optional parameters (prepared-name ""))
+ (make-instance 'command-object
+ :expression expression
+ :parameters parameters
+ :prepared-name prepared-name))
"While accessing database ~A~% Warning: ~A~% has occurred."
(sql-warning-database c)
(sql-warning-message c)))))
+
+(define-condition database-too-strange (sql-user-error)
+ ()
+ (:documentation "Used to signal cases where CLSQL is going to fail at
+ mapping your database correctly"))
+
+(defun signal-database-too-strange (message)
+ (error 'database-too-strange :message message))
(defvar *sql-stream* nil
"stream which accumulates SQL output")
+(defclass %database-identifier ()
+ ((escaped :accessor escaped :initarg :escaped :initform nil)
+ (unescaped :accessor unescaped :initarg :unescaped :initform nil))
+ (:documentation
+ "A database identifier represents a string/symbol ready to be spliced
+ into a sql string. It keeps references to both the escaped and
+ unescaped versions so that unescaped versions can be compared to the
+ results of list-tables/views/attributes etc. It also allows you to be
+ sure that an identifier is escaped only once.
+
+ (escaped-database-identifiers *any-reasonable-object*) should be called to
+ produce a string that is safe to splice directly into sql strings.
+
+ (unescaped-database-identifier *any-reasonable-object*) is generally what
+ you pass to it with the exception that symbols have been
+ clsql-sys:sql-escape which converts to a string and changes - to _ (so
+ that unescaped can be compared to the results of eg: list-tables)
+ "))
+
+(defmethod escaped ((it null)) it)
+(defmethod unescaped ((it null)) it)
+
+(defun database-identifier-equal (i1 i2 &optional (database clsql-sys:*default-database*))
+ (setf i1 (database-identifier i1 database)
+ i2 (database-identifier i2 database))
+ (flet ((cast (i)
+ (if (symbolp (unescaped i))
+ (sql-escape (unescaped i))
+ (unescaped i))))
+ (or ;; check for an exact match
+ (equal (escaped-database-identifier i1)
+ (escaped-database-identifier i2))
+ ;; check for an inexact match if we had symbols in the mix
+ (string-equal (cast i1) (cast i2)))))
+
+(defun delistify-dsd (list)
+ "Some MOPs, like openmcl 0.14.2, cons attribute values in a list."
+ (if (and (listp list) (null (cdr list)))
+ (car list)
+ list))
+
+(defun special-char-p (s)
+ "Check if a string has any special characters"
+ (loop for char across s
+ thereis (find char '(#\space #\, #\. #\! #\@ #\# #\$ #\% #\' #\"
+ #\^ #\& #\* #\| #\( #\) #\- #\+ #\< #\>
+ #\{ #\}))))
+
+(defun %make-database-identifier (inp &optional database)
+ "We want to quote an identifier if it came to us as a string or if it has special characters
+ in it."
+ (labels ((%escape-identifier (inp &optional orig)
+ "Quote an identifier unless it is already quoted"
+ (cond
+ ;; already quoted
+ ((and (eql #\" (elt inp 0))
+ (eql #\" (elt inp (- (length inp) 1))))
+ (make-instance '%database-identifier :unescaped (or orig inp) :escaped inp))
+ (T (make-instance
+ '%database-identifier :unescaped (or orig inp) :escaped
+ (concatenate
+ 'string "\"" (replace-all inp "\"" "\\\"") "\""))))))
+ (typecase inp
+ (string (%escape-identifier inp))
+ (%database-identifier inp)
+ (symbol
+ (let ((s (sql-escape inp)))
+ (if (and (not (eql '* inp)) (special-char-p s))
+ (%escape-identifier (convert-to-db-default-case s database) inp)
+ (make-instance '%database-identifier :escaped s :unescaped inp)))))))
+
+(defun combine-database-identifiers (ids &optional (database clsql-sys:*default-database*)
+ &aux res all-sym? pkg)
+ "Create a new database identifier by combining parts in a reasonable way
+ "
+ (setf ids (mapcar #'database-identifier ids)
+ all-sym? (every (lambda (i) (symbolp (unescaped i))) ids)
+ pkg (when all-sym? (symbol-package (unescaped (first ids)))))
+ (labels ((cast ( i )
+ (typecase i
+ (null nil)
+ (%database-identifier (cast (unescaped i)))
+ (symbol
+ (if all-sym?
+ (sql-escape i)
+ (convert-to-db-default-case (sql-escape i) database)))
+ (string i)))
+ (comb (i1 i2)
+ (setf i1 (cast i1)
+ i2 (cast i2))
+ (if (and i1 i2)
+ (concatenate 'string (cast i1) "_" (cast i2))
+ (or i1 i2))))
+ (setf res (reduce #'comb ids))
+ (database-identifier
+ (if all-sym? (intern res pkg) res)
+ database)))
+
+(defun escaped-database-identifier (name &optional database find-class-p)
+ (escaped (database-identifier name database find-class-p)))
+
+(defun unescaped-database-identifier (name &optional database find-class-p)
+ (unescaped (database-identifier name database find-class-p)))
+
(defun sql-output (sql-expr &optional (database *default-database*))
"Top-level call for generating SQL strings. Returns an SQL
string appropriate for DATABASE which corresponds to the
(write-string (database-output-sql expr database) *sql-stream*)
(values))
-(defvar *output-hash* (make-hash-table :test #'equal)
- "For caching generated SQL strings.")
+
+(defvar *output-hash*
+ (make-weak-hash-table :test #'equal)
+ "For caching generated SQL strings, set to NIL to disable."
+ )
(defmethod output-sql :around ((sql t) database)
- (let* ((hash-key (output-sql-hash-key sql database))
- (hash-value (when hash-key (gethash hash-key *output-hash*))))
- (cond ((and hash-key hash-value)
- (write-string hash-value *sql-stream*))
- (hash-key
- (let ((*sql-stream* (make-string-output-stream)))
- (call-next-method)
- (setf hash-value (get-output-stream-string *sql-stream*))
- (setf (gethash hash-key *output-hash*) hash-value))
- (write-string hash-value *sql-stream*))
- (t
- (call-next-method)))))
+ (if (null *output-hash*)
+ (call-next-method)
+ (let* ((hash-key (output-sql-hash-key sql database))
+ (hash-value (when hash-key (gethash hash-key *output-hash*))))
+ (cond ((and hash-key hash-value)
+ (write-string hash-value *sql-stream*))
+ (hash-key
+ (let ((*sql-stream* (make-string-output-stream)))
+ (call-next-method)
+ (setf hash-value (get-output-stream-string *sql-stream*))
+ (setf (gethash hash-key *output-hash*) hash-value))
+ (write-string hash-value *sql-stream*))
+ (t
+ (call-next-method))))))
(defmethod output-sql-hash-key (expr database)
(declare (ignore expr database))
sql
`(make-instance 'sql-ident :name ',name)))
+(defmethod output-sql ((expr %database-identifier) database)
+ (write-string (escaped expr) *sql-stream*))
+
(defmethod output-sql ((expr sql-ident) database)
(with-slots (name) expr
- (write-string
- (etypecase name
- (string name)
- (symbol (symbol-name name)))
- *sql-stream*))
+ (write-string (escaped-database-identifier name database) *sql-stream*))
t)
;; For SQL Identifiers for attributes
(defmethod collect-table-refs ((sql sql-ident-attribute))
(let ((qual (slot-value sql 'qualifier)))
(when qual
- (list (make-instance 'sql-ident-table :name qual)))))
+ ;; going to be used as a table, search classes
+ (list (make-instance
+ 'sql-ident-table
+ :name (database-identifier qual nil t))))))
(defmethod make-load-form ((sql sql-ident-attribute) &optional environment)
(declare (ignore environment))
:qualifier ',qualifier
:type ',type)))
-(defmethod output-sql ((expr sql-ident-attribute) database)
- (with-slots (qualifier name type) expr
- (if (and (not qualifier) (not type))
- (etypecase name
- (string
- (write-string name *sql-stream*))
- (symbol
- (write-string
- (sql-escape (symbol-name name)) *sql-stream*)))
-
- ;;; KMR: The TYPE field is used by CommonSQL for type conversion -- it
- ;;; should not be output in SQL statements
- #+ignore
- (format *sql-stream* "~@[~A.~]~A~@[ ~A~]"
- (when qualifier
- (sql-escape qualifier))
- (sql-escape name)
- (when type
- (symbol-name type)))
- (format *sql-stream* "~@[~A.~]~A"
- (when qualifier
- (typecase qualifier
- (string (format nil "~s" qualifier))
- (t (sql-escape qualifier))))
- (typecase name
- (string (format nil "~s" (sql-escape name)))
- (t (sql-escape name)))))
- t))
-
(defmethod output-sql-hash-key ((expr sql-ident-attribute) database)
(with-slots (qualifier name type)
expr
(list (and database (database-underlying-type database))
- 'sql-ident-attribute qualifier name type)))
+ 'sql-ident-attribute
+ (unescaped-database-identifier qualifier)
+ (unescaped-database-identifier name) type)))
;; For SQL Identifiers for tables
sql
`(make-instance 'sql-ident-table :name ',name :table-alias ',alias)))
-(defun special-char-p (s)
- "Check if a string has any special characters"
- (loop for char across s
- thereis (find char '(#\space #\, #\. #\! #\@ #\# #\$ #\%
- #\^ #\& #\* #\| #\( #\) #\- #\+))))
-
(defmethod output-sql ((expr sql-ident-table) database)
(with-slots (name alias) expr
(flet ((p (s) ;; the etypecase is in sql-escape too
- (let ((sym? (symbolp s))
- (s (sql-escape s)))
- (format *sql-stream*
- (if (and sym? (not (special-char-p s)))
- "~a" "~s")
- s))))
+ (write-string
+ (escaped-database-identifier s database)
+ *sql-stream*)))
(p name)
(when alias
(princ #\space *sql-stream*)
(p alias))))
t)
+(defmethod output-sql ((expr sql-ident-attribute) database)
+;;; KMR: The TYPE field is used by CommonSQL for type conversion -- it
+;;; should not be output in SQL statements
+ (let ((*print-pretty* nil))
+ (with-slots (qualifier name type) expr
+ (format *sql-stream* "~@[~a.~]~a"
+ (when qualifier
+ ;; check for classes
+ (escaped-database-identifier qualifier database T))
+ (escaped-database-identifier name database))
+ t)))
+
(defmethod output-sql-hash-key ((expr sql-ident-table) database)
(with-slots (name alias)
expr
(list (and database (database-underlying-type database))
- 'sql-ident-table name alias)))
+ 'sql-ident-table
+ (unescaped-database-identifier name)
+ (unescaped-database-identifier alias))))
(defclass sql-relational-exp (%sql-expression)
((operator
(dolist (exp (slot-value sql 'sub-expressions))
(let ((refs (collect-table-refs exp)))
(if refs (setf tabs (append refs tabs)))))
- (remove-duplicates tabs
- :test (lambda (tab1 tab2)
- (equal (slot-value tab1 'name)
- (slot-value tab2 'name))))))
+ (remove-duplicates tabs :test #'database-identifier-equal)))
;; Write SQL for relational operators (like 'AND' and 'OR').
;; should do arity checking of subexpressions
+(defun %write-operator (operator database)
+ (typecase operator
+ (string (write-string operator *sql-stream*))
+ (symbol (write-string (symbol-name operator) *sql-stream*))
+ (T (output-sql operator database))))
+
(defmethod output-sql ((expr sql-relational-exp) database)
(with-slots (operator sub-expressions) expr
;; we do this as two runs so as not to emit confusing superflous parentheses
(loop for str-sub in (rest str-subs)
do
(write-char #\Space *sql-stream*)
- (output-sql operator database)
+ ;; do this so that symbols can be output as database identifiers
+ ;; rather than allowing symbols to inject sql
+ (%write-operator operator database)
(write-char #\Space *sql-stream*)
(write-string str-sub *sql-stream*))
(write-char #\) *sql-stream*))
((null (cdr sub)) (output-sql (car sub) database))
(output-sql (car sub) database)
(write-char #\Space *sql-stream*)
- (output-sql operator database)
+ (%write-operator operator database)
(write-char #\Space *sql-stream*)))
t)
(dolist (exp (slot-value sql 'components))
(let ((refs (collect-table-refs exp)))
(if refs (setf tabs (append refs tabs)))))
- (remove-duplicates tabs
- :test (lambda (tab1 tab2)
- (equal (slot-value tab1 'name)
- (slot-value tab2 'name)))))
+ (remove-duplicates tabs :test #'database-identifier-equal))
nil)))
(if modifier
(progn
(write-char #\( *sql-stream*)
- (output-sql modifier database)
+ (cond
+ ((sql-operator modifier)
+ (%write-operator modifier database))
+ ((or (stringp modifier) (symbolp modifier))
+ (write-string
+ (escaped-database-identifier modifier)
+ *sql-stream*))
+ (t (output-sql modifier database)))
(write-char #\Space *sql-stream*)
(output-sql components database)
(write-char #\) *sql-stream*))
(dolist (exp (slot-value sql 'args))
(let ((refs (collect-table-refs exp)))
(if refs (setf tabs (append refs tabs)))))
- (remove-duplicates tabs
- :test (lambda (tab1 tab2)
- (equal (slot-value tab1 'name)
- (slot-value tab2 'name))))))
+ (remove-duplicates tabs :test #'database-identifier-equal)))
(defvar *in-subselect* nil)
(defmethod output-sql ((expr sql-function-exp) database)
(with-slots (name args)
expr
- (output-sql name database)
+ (typecase name
+ ((or string symbol)
+ (write-string (escaped-database-identifier name) *sql-stream*))
+ (t (output-sql name database)))
(let ((*in-subselect* nil)) ;; aboid double parens
(when args (output-sql args database))))
t)
expr
(%write-operator modifier database)
(write-string " " *sql-stream*)
- (output-sql (car components) database)
+ (%write-operator (car components) database)
(when components
(mapc #'(lambda (comp)
(write-string ", " *sql-stream*)
(dolist (exp (slot-value sql 'sub-expressions))
(let ((refs (collect-table-refs exp)))
(if refs (setf tabs (append refs tabs)))))
- (remove-duplicates tabs
- :test (lambda (tab1 tab2)
- (equal (slot-value tab1 'name)
- (slot-value tab2 'name))))))
+ (remove-duplicates tabs :test #'database-identifier-equal)))
(defmethod output-sql ((expr sql-set-exp) database)
(with-slots (operator sub-expressions)
(car sub-expressions)
sub-expressions)))
(when (= (length subs) 1)
- (output-sql operator database)
+ (%write-operator operator database)
(write-char #\Space *sql-stream*))
(do ((sub subs (cdr sub)))
((null (cdr sub)) (output-sql (car sub) database))
(output-sql (car sub) database)
(write-char #\Space *sql-stream*)
- (output-sql operator database)
+ (%write-operator operator database)
(write-char #\Space *sql-stream*))))
t)
:initform nil)))
(defmethod collect-table-refs ((sql sql-query))
- (remove-duplicates (collect-table-refs (slot-value sql 'where))
- :test (lambda (tab1 tab2)
- (equal (slot-value tab1 'name)
- (slot-value tab2 'name)))))
+ (remove-duplicates
+ (collect-table-refs (slot-value sql 'where))
+ :test #'database-identifier-equal))
(defvar *select-arguments*
'(:all :database :distinct :flatp :from :group-by :having :order-by
(output-sql (apply #'vector selections) database))
(when from
(write-string " FROM " *sql-stream*)
- (flet ((ident-table-equal (a b)
- (and (if (and (eql (type-of a) 'sql-ident-table)
- (eql (type-of b) 'sql-ident-table))
- (string-equal (slot-value a 'alias)
- (slot-value b 'alias))
- t)
- (string-equal (sql-escape (slot-value a 'name))
- (sql-escape (slot-value b 'name))))))
- (typecase from
- (list (output-sql (apply #'vector
- (remove-duplicates from
- :test #'ident-table-equal))
- database))
- (string (format *sql-stream* "~s" (sql-escape from)))
- (t (let ((*in-subselect* t))
- (output-sql from database))))))
+ (typecase from
+ (list (output-sql
+ (apply #'vector
+ (remove-duplicates from :test #'database-identifier-equal))
+ database))
+ (string (write-string
+ (escaped-database-identifier from database)
+ *sql-stream*))
+ (t (let ((*in-subselect* t))
+ (output-sql from database)))))
(when inner-join
(write-string " INNER JOIN " *sql-stream*)
(output-sql inner-join database))
(write-string " ON " *sql-stream*)
(output-sql on database))
(when where
- (write-string " WHERE " *sql-stream*)
- (let ((*in-subselect* t))
- (output-sql where database)))
+ (let ((where-out (string-trim
+ '(#\newline #\space #\tab #\return)
+ (with-output-to-string (*sql-stream*)
+ (let ((*in-subselect* t))
+ (output-sql where database))))))
+ (when (> (length where-out) 0)
+ (write-string " WHERE " *sql-stream*)
+ (write-string where-out *sql-stream*))))
(when group-by
(write-string " GROUP BY " *sql-stream*)
(if (listp group-by)
(with-slots (name columns modifiers transactions)
stmt
(write-string "CREATE TABLE " *sql-stream*)
- (etypecase name
- (string (format *sql-stream* "~s" (sql-escape name)))
- (symbol (write-string (sql-escape name) *sql-stream*))
- (sql-ident (output-sql name database)))
+ (write-string (escaped-database-identifier name database) *sql-stream*)
(write-string " (" *sql-stream*)
(do ((column columns (cdr column)))
((null (cdr column))
(defmethod database-output-sql ((sym symbol) database)
(if (null sym)
+null-string+
- (if (equal (symbol-package sym) keyword-package)
- (concatenate 'string "'" (string sym) "'")
- (symbol-name sym)))))
+ (if (equal (symbol-package sym) keyword-package)
+ (database-output-sql (symbol-name sym) database)
+ (escaped-database-identifier sym)))))
(defmethod database-output-sql ((tee (eql t)) database)
(if database
(if (< 1 (length constraint))
(setq string (concatenate 'string string " "))))))))
+(defmethod database-identifier ( name &optional database find-class-p
+ &aux cls)
+ "A function that takes whatever you give it, recurively coerces it,
+ and returns a database-identifier.
+
+ (escaped-database-identifiers *any-reasonable-object*) should be called to
+ produce a string that is safe to splice directly into sql strings.
+
+ This function should NOT throw errors when database is nil
+
+ find-class-p should be T if we want to search for classes
+ and check their use their view table. Should be used
+ on symbols we are sure indicate tables
+
+
+ ;; metaclasses has further typecases of this, so that it will
+ ;; load less painfully (try-recompiles) in SBCL
+
+ "
+ (flet ((flatten-id (id)
+ "if we have multiple pieces that we need to represent as
+ db-id lets do that by rendering out the id, then creating
+ a new db-id with that string as escaped"
+ (let ((s (sql-output id database)))
+ (make-instance '%database-identifier :escaped s :unescaped s))))
+ (etypecase name
+ (null nil)
+ (string (%make-database-identifier name database))
+ (symbol
+ ;; if this is being used as a table, we should check
+ ;; for a class with this name and use the identifier specified
+ ;; on it
+ (if (and find-class-p (setf cls (find-standard-db-class name)))
+ (database-identifier cls)
+ (%make-database-identifier name database)))
+ (%database-identifier name)
+ ;; we know how to deref this without further escaping
+ (sql-ident-table
+ (with-slots ((inner-name name) alias) name
+ (if alias
+ (flatten-id name)
+ (database-identifier inner-name))))
+ ;; if this is a single name we can derefence it
+ (sql-ident-attribute
+ (with-slots (qualifier (inner-name name)) name
+ (if qualifier
+ (flatten-id name)
+ (database-identifier inner-name))))
+ (sql-ident
+ (with-slots ((inner-name name)) name
+ (database-identifier inner-name)))
+ ;; dont know how to handle this really :/
+ (%sql-expression (flatten-id name))
+ )))
+
(in-package #:clsql-sys)
-;; Utilities
-
-(defun database-identifier (name database)
- (sql-escape (etypecase name
- ;; honor case of strings
- (string name)
- (sql-ident (sql-output name database))
- (symbol (sql-output name database)))))
-
-
;; Truncate database
(defun truncate-database (&key (database *default-database*))
*DEFAULT-DATABASE*. If the table does not exist and
IF-DOES-NOT-EXIST is :ignore then DROP-TABLE returns nil whereas
an error is signalled if IF-DOES-NOT-EXIST is :error."
- (let ((table-name (database-identifier name database)))
(ecase if-does-not-exist
(:ignore
- (unless (table-exists-p table-name :database database
- :owner owner)
+ (unless (table-exists-p name :database database :owner owner)
(return-from drop-table nil)))
(:error
t))
-
- (let ((expr (etypecase name
- ;; keep quotes for strings for mixed-case names
- (string (format nil "DROP TABLE ~S" table-name))
- ((or symbol sql-ident)
- (concatenate 'string "DROP TABLE " table-name)))))
+
+ (let ((expr (concatenate 'string "DROP TABLE " (escaped-database-identifier name database))))
;; Fixme: move to clsql-oracle
(when (and (find-package 'clsql-oracle)
(eq :oracle (database-type database))
(symbol-name '#:clsql-oracle)))))
(setq expr (concatenate 'string expr " PURGE")))
- (execute-command expr :database database))))
+ (execute-command expr :database database)))
(defun list-tables (&key (owner nil) (database *default-database*))
"Returns a list of strings representing table names in DATABASE
listed. If OWNER is :all then all tables are listed."
(database-list-tables database :owner owner))
+(defmethod %table-exists-p (name (database T) &key owner )
+ (unless database (setf database *default-database*))
+ (let ((name (database-identifier name database))
+ (tables (list-tables :owner owner :database database)))
+ (when (member name tables :test #'database-identifier-equal)
+ t)))
+
(defun table-exists-p (name &key (owner nil) (database *default-database*))
"Tests for the existence of an SQL table called NAME in DATABASE
which defaults to *DEFAULT-DATABASE*. OWNER is nil by default
OWNER is a string denoting a user name, only tables owned by
OWNER are examined. If OWNER is :all then all tables are
examined."
- (when (member (database-identifier name database)
- (list-tables :owner owner :database database)
- :test #'string-equal)
- t))
+ (%table-exists-p name database :owner owner))
;; Views
parameter. The WITH-CHECK-OPTION is nil by default but if it has
a non-nil value, then all insert/update commands on the view are
checked to ensure that the new data satisfy the query AS."
- (let* ((view-name (etypecase name
- (symbol (sql-expression :attribute name))
- (string (sql-expression :attribute (make-symbol name)))
- (sql-ident name)))
+ (let* ((view-name (database-identifier name))
(stmt (make-instance 'sql-create-view
:name view-name
:column-list column-list
*DEFAULT-DATABASE*. If the view does not exist and
IF-DOES-NOT-EXIST is :ignore then DROP-VIEW returns nil whereas
an error is signalled if IF-DOES-NOT-EXIST is :error."
- (let ((view-name (database-identifier name database)))
(ecase if-does-not-exist
(:ignore
- (unless (view-exists-p view-name :database database)
+ (unless (view-exists-p name :database database)
(return-from drop-view)))
(:error
t))
- (let ((expr (concatenate 'string "DROP VIEW " view-name)))
- (execute-command expr :database database))))
+ (let ((expr (concatenate 'string "DROP VIEW " (escaped-database-identifier name database))))
+ (execute-command expr :database database)))
(defun list-views (&key (owner nil) (database *default-database*))
"Returns a list of strings representing view names in DATABASE
examined. If OWNER is :all then all views are examined."
(when (member (database-identifier name database)
(list-views :owner owner :database database)
- :test #'string-equal)
+ :test #'database-identifier-equal)
t))
ATTRIBUTES. The UNIQUE argument is nil by default but if it has a
non-nil value then the indexed attributes must have unique
values."
- (let* ((index-name (database-identifier name database))
- (table-name (database-identifier on database))
- (attributes (mapcar #'(lambda (a) (database-identifier a database)) (listify attributes)))
+ (let* ((index-name (escaped-database-identifier name database))
+ (table-name (escaped-database-identifier on database))
+ (attributes (mapcar #'(lambda (a) (escaped-database-identifier a database))
+ (listify attributes)))
(stmt (format nil "CREATE ~A INDEX ~A ON ~A (~{~A~^, ~})"
(if unique "UNIQUE" "")
index-name table-name attributes)))
an error is signalled if IF-DOES-NOT-EXIST is :error. The
argument ON allows the optional specification of a table to drop
the index from."
- (let ((index-name (database-identifier name database)))
- (ecase if-does-not-exist
- (:ignore
- (unless (index-exists-p index-name :database database)
- (return-from drop-index)))
- (:error t))
- (let* ((db-type (database-underlying-type database))
- (index-identifier (cond ((db-type-use-fully-qualified-column-on-drop-index? db-type)
- (format nil "~A.~A" (database-identifier on database) index-name))
- ((db-type-use-column-on-drop-index? db-type)
- (format nil "~A ON ~A" index-name (database-identifier on database)))
- (t index-name))))
- (execute-command (format nil "DROP INDEX ~A" index-identifier)
- :database database))))
+ (ecase if-does-not-exist
+ (:ignore
+ (unless (index-exists-p name :database database)
+ (return-from drop-index)))
+ (:error t))
+ (let* ((db-type (database-underlying-type database))
+ (on (when on (escaped-database-identifier on database)))
+ (index-name (escaped-database-identifier name database))
+ (index-identifier
+ (cond ((db-type-use-fully-qualified-column-on-drop-index? db-type)
+ (format nil "~A.~A" on index-name))
+ ((db-type-use-column-on-drop-index? db-type)
+ (format nil "~A ON ~A" index-name on))
+ (t index-name))))
+ (execute-command (format nil "DROP INDEX ~A" index-identifier)
+ :database database)))
(defun list-indexes (&key (owner nil) (database *default-database*) (on nil))
"Returns a list of strings representing index names in DATABASE
such table identifiers."
(if (null on)
(database-list-indexes database :owner owner)
- (let ((tables (typecase on (cons on) (t (list on)))))
- (reduce #'append
- (mapcar #'(lambda (table) (database-list-table-indexes
- (database-identifier table database)
- database :owner owner))
- tables)))))
+ (let ((tables (typecase on
+ (cons on)
+ (t (list on)))))
+ (reduce
+ #'append
+ (mapcar #'(lambda (table)
+ (database-list-table-indexes table database :owner owner))
+ tables)))))
(defun index-exists-p (name &key (owner nil) (database *default-database*))
"Tests for the existence of an SQL index called NAME in DATABASE
examined."
(when (member (database-identifier name database)
(list-indexes :owner owner :database database)
- :test #'string-equal)
+ :test #'database-identifier-equal)
t))
;; Attributes
are listed. If OWNER is a string denoting a user name, only
attributes owned by OWNER are listed. If OWNER is :all then all
attributes are listed."
- (database-list-attributes (database-identifier name database) database
+ (database-list-attributes (escaped-database-identifier name database) database
:owner owner))
(defun attribute-type (attribute table &key (owner nil)
attribute, if it exists, must be owned by OWNER else nil is
returned, whereas if OWNER is :all then the attribute, if it
exists, will be returned regardless of its owner."
- (database-attribute-type (database-identifier attribute database)
- (database-identifier table database)
+ (database-attribute-type (escaped-database-identifier attribute database)
+ (escaped-database-identifier table database)
database
:owner owner))
the fourth is the scale of the attribute and the fifth is 1 if
the attribute accepts null values and otherwise 0."
(with-slots (attribute-cache) database
- (let ((table-ident (database-identifier table database)))
+ (let ((table-ident (escaped-database-identifier table database)))
(multiple-value-bind (val found) (gethash table-ident attribute-cache)
(if (and found (second val))
(second val)
(cons attribute
(multiple-value-list
(database-attribute-type
- (database-identifier attribute
+ (escaped-database-identifier attribute
database)
table-ident
database
*DEFAULT-DATABASE*. If the sequence does not exist and
IF-DOES-NOT-EXIST is :ignore then DROP-SEQUENCE returns nil
whereas an error is signalled if IF-DOES-NOT-EXIST is :error."
- (let ((sequence-name (database-identifier name database)))
- (ecase if-does-not-exist
- (:ignore
- (unless (sequence-exists-p sequence-name :database database)
- (return-from drop-sequence)))
- (:error t))
- (database-drop-sequence sequence-name database))
+ (ecase if-does-not-exist
+ (:ignore
+ (unless (sequence-exists-p name :database database)
+ (return-from drop-sequence)))
+ (:error t))
+ (database-drop-sequence name database)
(values))
(defun list-sequences (&key (owner nil) (database *default-database*))
examined. If OWNER is a string denoting a user name, only
sequences owned by OWNER are examined. If OWNER is :all then all
sequences are examined."
- (when (member (database-identifier name database)
- (list-sequences :owner owner :database database)
- :test #'string-equal)
- t))
+ (let ((seqs (list-sequences :owner owner :database database))
+ ;; handle symbols, we know the db will return strings
+ (n1 (database-identifier name database))
+ (n2 (%sequence-name-to-table name database)))
+ (when (or (member n1 seqs :test #'database-identifier-equal)
+ (member n2 seqs :test #'database-identifier-equal))
+ t)))
(defun sequence-next (name &key (database *default-database*))
"Increment and return the next value in the sequence called
(subquery nil))
(unless into
(error 'sql-user-error :message ":into keyword not supplied"))
- (let ((insert (make-instance 'sql-insert :into into)))
+ (let ((insert (make-instance 'sql-insert :into (database-identifier into nil))))
(with-slots (attributes values query)
insert
"Deletes records satisfying the SQL expression WHERE from the
table specified by FROM in DATABASE specifies a database which
defaults to *DEFAULT-DATABASE*."
- (let ((stmt (make-instance 'sql-delete :from from :where where)))
+ (let ((stmt (make-instance 'sql-delete :from (database-identifier from database) :where where)))
(execute-command stmt :database database)))
(defun update-records (table &key (attributes nil)
(when av-pairs
(setf attributes (mapcar #'car av-pairs)
values (mapcar #'cadr av-pairs)))
- (let ((stmt (make-instance 'sql-update :table table
+ (let ((stmt (make-instance 'sql-update :table (database-identifier table database)
:attributes attributes
:values values
:where where)))
(database-query
(format
nil
- "select indexrelid from pg_index where indrelid=(select relfilenode from pg_class where relname='~A'~A)"
- (string-downcase table)
+ "select indexrelid from pg_index where indrelid=(select relfilenode from pg_class where LOWER(relname)='~A'~A)"
+ (string-downcase (unescaped-database-identifier table))
(owner-clause owner))
database :auto nil))
(result nil))
database nil nil))))
(when row
(destructuring-bind (typname attlen atttypmod attnull) row
-
- (setf attlen (parse-integer attlen :junk-allowed t)
- atttypmod (parse-integer atttypmod :junk-allowed t))
-
+ (setf attlen (%get-int attlen)
+ atttypmod (%get-int atttypmod))
(let ((coltype (ensure-keyword typname))
- (colnull (if (string-equal "f" attnull) 1 0))
+ (colnull (typecase attnull
+ (string (if (string-equal "f" attnull) 1 0))
+ (null 1)
+ (T 0)))
collen
colprec)
- (setf (values collen colprec)
- (case coltype
- ((:numeric :decimal)
- (if (= -1 atttypmod)
- (values nil nil)
- (values (ash (- atttypmod 4) -16)
- (boole boole-and (- atttypmod 4) #xffff))))
- (otherwise
- (values
- (cond ((and (= -1 attlen) (= -1 atttypmod)) nil)
- ((= -1 attlen) (- atttypmod 4))
- (t attlen))
- nil))))
- (values coltype collen colprec colnull))))))
+ (setf (values collen colprec)
+ (case coltype
+ ((:numeric :decimal)
+ (if (= -1 atttypmod)
+ (values nil nil)
+ (values (ash (- atttypmod 4) -16)
+ (boole boole-and (- atttypmod 4) #xffff))))
+ (otherwise
+ (values
+ (cond ((and (= -1 attlen) (= -1 atttypmod)) nil)
+ ((= -1 attlen) (- atttypmod 4))
+ (t attlen))
+ nil))))
+ (values coltype collen colprec colnull))))))
(defmethod database-create-sequence (sequence-name
(database generic-postgresql-database))
- (database-execute-command
- (concatenate 'string "CREATE SEQUENCE " (sql-escape sequence-name))
- database))
+ (let ((cmd (concatenate
+ 'string "CREATE SEQUENCE " (escaped-database-identifier sequence-name database))))
+ (database-execute-command cmd database)))
(defmethod database-drop-sequence (sequence-name
(database generic-postgresql-database))
(database-execute-command
- (concatenate 'string "DROP SEQUENCE " (sql-escape sequence-name)) database))
+ (concatenate 'string "DROP SEQUENCE " (escaped-database-identifier sequence-name database))
+ database))
(defmethod database-list-sequences ((database generic-postgresql-database)
&key (owner nil))
(defmethod database-set-sequence-position (name (position integer)
(database generic-postgresql-database))
(values
- (parse-integer
+ (%get-int
(caar
(database-query
- (format nil "SELECT SETVAL ('~A', ~A)" name position)
+ (format nil "SELECT SETVAL ('~A', ~A)" (escaped-database-identifier name) position)
database nil nil)))))
(defmethod database-sequence-next (sequence-name
(database generic-postgresql-database))
(values
- (parse-integer
+ (%get-int
(caar
(database-query
- (concatenate 'string "SELECT NEXTVAL ('" (sql-escape sequence-name) "')")
+ (concatenate 'string "SELECT NEXTVAL ('" (escaped-database-identifier sequence-name) "')")
database nil nil)))))
(defmethod database-sequence-last (sequence-name (database generic-postgresql-database))
(values
- (parse-integer
+ (%get-int
(caar
(database-query
- (concatenate 'string "SELECT LAST_VALUE FROM " sequence-name)
+ (concatenate 'string "SELECT LAST_VALUE FROM " (escaped-database-identifier sequence-name))
database nil nil)))))
+(defmethod auto-increment-sequence-name (table column (database generic-postgresql-database))
+ (let* ((sequence-name (or (database-identifier (slot-value column 'autoincrement-sequence))
+ (combine-database-identifiers
+ (list table column 'seq)
+ database))))
+ (when (search "'" (escaped-database-identifier sequence-name)
+ :test #'string-equal)
+ (signal-database-too-strange
+ "PG Sequence names shouldnt contain single quotes for the sake of sanity"))
+ sequence-name))
+
(defmethod database-last-auto-increment-id ((database generic-postgresql-database) table column)
- (let (column-helper seq-name)
- (typecase table
- (sql-ident (setf table (slot-value table 'name)))
- (standard-db-class (setf table (view-table table))))
- (typecase column
- (sql-ident (setf column-helper (slot-value column 'name)))
- (view-class-slot-definition-mixin
- (setf column-helper (view-class-slot-column column))))
- (setq seq-name (or (view-class-slot-autoincrement-sequence column)
- (convert-to-db-default-case (format nil "~a_~a_seq" table column-helper) database)))
- (first (clsql:query (format nil "SELECT currval ('~a')" seq-name)
+ (let ((seq-name (auto-increment-sequence-name table column database)))
+ (first (clsql:query (format nil "SELECT currval ('~a')"
+ (escaped-database-identifier seq-name))
:flatp t
:database database
:result-types '(:int)))))
-(defmethod database-generate-column-definition (class slotdef (database generic-postgresql-database))
- ; handle autoincr slots special
- (when (or (and (listp (view-class-slot-db-constraints slotdef))
- (member :auto-increment (view-class-slot-db-constraints slotdef)))
- (eql :auto-increment (view-class-slot-db-constraints slotdef))
- (slot-value slotdef 'autoincrement-sequence))
- (let ((sequence-name (database-make-autoincrement-sequence class slotdef database)))
- (setf (view-class-slot-autoincrement-sequence slotdef) sequence-name)
- (cond ((listp (view-class-slot-db-constraints slotdef))
- (setf (view-class-slot-db-constraints slotdef)
- (remove :auto-increment
- (view-class-slot-db-constraints slotdef)))
- (unless (member :default (view-class-slot-db-constraints slotdef))
- (setf (view-class-slot-db-constraints slotdef)
- (append
- (list :default (format nil "nextval('~a')" sequence-name))
- (view-class-slot-db-constraints slotdef)))))
- (t
- (setf (view-class-slot-db-constraints slotdef)
- (list :default (format nil "nextval('~a')" sequence-name)))))))
- (call-next-method class slotdef database))
-
-(defmethod database-make-autoincrement-sequence (table column (database generic-postgresql-database))
- (let* ((table-name (view-table table))
- (column-name (view-class-slot-column column))
- (sequence-name (or (slot-value column 'autoincrement-sequence)
- (convert-to-db-default-case
- (format nil "~a_~a_SEQ" table-name column-name) database))))
- (unless (sequence-exists-p sequence-name :database database)
- (database-create-sequence sequence-name database))
- sequence-name))
+(defmethod database-generate-column-definition
+ (class slotdef (database generic-postgresql-database))
+ (when (member (view-class-slot-db-kind slotdef) '(:base :key))
+ (let ((cdef
+ (list (sql-expression :attribute (database-identifier slotdef database))
+ (specified-type slotdef)
+ (view-class-slot-db-type slotdef)))
+ (const (listify (view-class-slot-db-constraints slotdef)))
+ (seq (auto-increment-sequence-name class slotdef database)))
+ (when seq
+ (setf const (remove :auto-increment const))
+ (unless (member :default const)
+ (let* ((next (format nil "nextval('~a')" (escaped-database-identifier seq))))
+ (setf const (append const (list :default next))))))
+ (append cdef const))))
+
+(defmethod database-add-autoincrement-sequence
+ ((self standard-db-class) (database generic-postgresql-database))
+ (let ((ordered-slots (if (normalizedp self)
+ (ordered-class-direct-slots self)
+ (ordered-class-slots self))))
+ (dolist (slotdef ordered-slots)
+
+ ;; ensure that referenceed sequences actually exist before referencing them
+ (let ((sequence-name (auto-increment-sequence-name self slotdef database)))
+ (when (and sequence-name
+ (not (sequence-exists-p sequence-name :database database)))
+ (create-sequence sequence-name :database database))))))
+
+(defmethod database-remove-autoincrement-sequence
+ ((table standard-db-class)
+ (database generic-postgresql-database))
+ (let ((ordered-slots
+ (if (normalizedp table)
+ (ordered-class-direct-slots table)
+ (ordered-class-slots table))))
+ (dolist (slotdef ordered-slots)
+ ;; ensure that referenceed sequences are dropped with the table
+ (let ((sequence-name (auto-increment-sequence-name table slotdef database)))
+ (when sequence-name (drop-sequence sequence-name))))))
(defun postgresql-database-list (connection-spec type)
(destructuring-bind (host name &rest other-args) connection-spec
;; FDML
+(defgeneric choose-database-for-instance (object &optional database)
+ (:documentation "Used by the oodml functions to select which
+ database object to use. Chooses the database associated with the
+ object primarily, falls back to the database provided as an argument
+ or the *DEFAULT-DATABASE*."))
(defgeneric execute-command (expression &key database)
(:documentation
using values from the slot values of OBJECT, and OBJECT becomes
associated with DATABASE."))
-(defgeneric delete-instance-records (object)
+(defgeneric delete-instance-records (object &key database)
(:documentation
"Deletes the records represented by OBJECT in the appropriate
table of the database associated with OBJECT. If OBJECT is not
)
(defgeneric read-sql-value (val type database db-type)
)
-(defgeneric database-make-autoincrement-sequence (class slotdef database)
- )
+(defgeneric database-add-autoincrement-sequence (class database)
+ (:method (class database) nil)
+ (:documentation "If a database needs to add a sequence for its
+ autoincrement to work, this is where it should go. Default is
+ that it doesnt so just return nil"))
+(defgeneric database-remove-autoincrement-sequence (class database)
+ (:method (class database) nil)
+ (:documentation "If a database needs to add a sequence for its
+ autoincrement to work, this is where it should go. Default is
+ that it doesnt so just return nil"))
+(defgeneric auto-increment-sequence-name (class slotdef database)
+ (:documentation "The sequence name to create for this autoincremnt column on this class
+ if returns nil, there is no associated sequence "))
+
+(defmethod auto-increment-sequence-name :around (class slot database)
+ (when (auto-increment-column-p slot database)
+ (call-next-method)))
(defgeneric database-last-auto-increment-id (database table column)
)
+
+
;; Generation of SQL strings from lisp expressions
(defgeneric output-sql (expr database)
((stringp arg)
(sql-escape arg))))
-(defun column-name-from-arg (arg)
- (cond ((symbolp arg)
- arg)
- ((typep arg 'sql-ident)
- (slot-value arg 'name))
- ((stringp arg)
- (intern (symbol-name-default-case arg)))))
-
-
(defun remove-keyword-arg (arglist akey)
(let ((mylist arglist)
(newlist ()))
list))
(declaim (inline delistify-dsd))
-(defun delistify-dsd (list)
- "Some MOPs, like openmcl 0.14.2, cons attribute values in a list."
- (if (and (listp list) (null (cdr list)))
- (car list)
- list))
-
+;; there is an :after method below too
(defmethod initialize-instance :around
((obj view-class-direct-slot-definition)
&rest initargs &key db-constraints db-kind type &allow-other-keys)
type db-constraints))
initargs))
+(defun compute-column-name (arg)
+ (database-identifier arg nil))
+
+(defmethod initialize-instance :after
+ ((obj view-class-direct-slot-definition)
+ &key &allow-other-keys)
+ (setf (view-class-slot-column obj) (compute-column-name obj)))
+
(defmethod compute-effective-slot-definition ((class standard-db-class)
#+kmr-normal-cesd slot-name
direct-slots)
(let ((esd (call-next-method)))
(typecase dsd
(view-class-slot-definition-mixin
- ;; Use the specified :column argument if it is supplied, otherwise
- ;; the column slot is filled in with the slot-name, but transformed
- ;; to be sql safe, - to _ and such.
- (setf (slot-value esd 'column)
- (column-name-from-arg
- (if (slot-boundp dsd 'column)
- (delistify-dsd (view-class-slot-column dsd))
- (column-name-from-arg
- (sql-escape (slot-definition-name dsd))))))
+ (setf (slot-value esd 'column) (compute-column-name dsd))
(setf (slot-value esd 'db-type)
(when (slot-boundp dsd 'db-type)
#+openmcl (setf (slot-value esd 'ccl::type-predicate)
type-predicate)))
- (setf (slot-value esd 'column)
- (column-name-from-arg
- (sql-escape (slot-definition-name dsd))))
-
+ ;; has no column name if it is not a database column
+ (setf (slot-value esd 'column) nil)
(setf (slot-value esd 'db-info) nil)
(setf (slot-value esd 'db-kind) :virtual)
(setf (specified-type esd) (slot-definition-type dsd)))
result))
(defun slotdef-for-slot-with-class (slot class)
- (find-if #'(lambda (d) (eql slot (slot-definition-name d)))
- (class-slots class)))
+ (typecase slot
+ (standard-slot-definition slot)
+ (symbol
+ (find-if #'(lambda (d) (eql slot (slot-definition-name d)))
+ (class-slots class)))))
#+ignore
(eval-when (:compile-toplevel :load-toplevel :execute)
#+kmr-normal-esdc
(setq cl:*features* (delete :kmr-normal-esdc cl:*features*))
)
+
+(defmethod database-identifier ( (name standard-db-class)
+ &optional database find-class-p)
+ "the majority of this function is in expressions.lisp
+ this is here to make loading be less painful (try-recompiles) in SBCL"
+ (database-identifier (view-table name) database))
+
+(defmethod database-identifier ((name view-class-slot-definition-mixin)
+ &optional database find-class-p)
+ (database-identifier
+ (if (slot-boundp name 'column)
+ (delistify-dsd (view-class-slot-column name))
+ (slot-definition-name name))
+ database))
+
+(defun find-standard-db-class (name &aux cls)
+ (and (setf cls (ignore-errors (find-class name)))
+ (typep cls 'standard-db-class)
+ cls))
(if tclass
(let ((*default-database* database)
(pclass (car (class-direct-superclasses tclass))))
- (when (and (normalizedp tclass) (not (table-exists-p (view-table pclass))))
+ (when (and (normalizedp tclass) (not (table-exists-p pclass)))
(create-view-from-class (class-name pclass)
:database database :transactions transactions))
(%install-class tclass database :transactions transactions))
(error "Class ~s not found." view-class-name)))
(values))
+(defmethod auto-increment-column-p (slotdef &optional (database clsql-sys:*default-database*))
+ (declare (ignore database))
+ (or (member :auto-increment (listify (view-class-slot-db-constraints slotdef)))
+ (slot-value slotdef 'autoincrement-sequence)))
(defmethod %install-class ((self standard-db-class) database
&key (transactions t))
(ordered-class-direct-slots self)
(ordered-class-slots self))))
(dolist (slotdef ordered-slots)
- (let ((res (database-generate-column-definition self
- slotdef database)))
+ (let ((res (database-generate-column-definition self slotdef database)))
(when res
(push res schemadef))))
(if (not schemadef)
(unless (normalizedp self)
(error "Class ~s has no :base slots" self))
(progn
- (create-table (sql-expression :table (view-table self)) (nreverse schemadef)
+ (database-add-autoincrement-sequence self database)
+ (create-table (sql-expression :table (database-identifier self database))
+ (nreverse schemadef)
:database database
:transactions transactions
:constraints (database-pkey-constraint self database))
t)
(defmethod database-pkey-constraint ((class standard-db-class) database)
- (let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class)))
- (table (view-table class)))
+ ;; Keylist will always be a list of escaped-indentifier
+ (let ((keylist (mapcar #'(lambda (x) (escaped-database-identifier x database))
+ (keyslots-for-class class)))
+ (table (escaped (combine-database-identifiers
+ (list class 'PK)
+ database))))
(when keylist
- (etypecase table
- (string
- (format nil "CONSTRAINT \"~APK\" PRIMARY KEY~A" table
- (sql-output keylist database)))
- ((or symbol sql-ident)
- (format nil "CONSTRAINT ~APK PRIMARY KEY~A" table
- (sql-output keylist database)))))))
+ (format nil "CONSTRAINT ~A PRIMARY KEY (~{~A~^,~})" table
+ keylist))))
(defmethod database-generate-column-definition (class slotdef database)
- (declare (ignore database class))
+ (declare (ignore class))
(when (member (view-class-slot-db-kind slotdef) '(:base :key))
(let ((cdef
- (list (sql-expression :attribute (view-class-slot-column slotdef))
+ (list (sql-expression :attribute (database-identifier slotdef database))
(specified-type slotdef))))
(setf cdef (append cdef (list (view-class-slot-db-type slotdef))))
(let ((const (view-class-slot-db-constraints slotdef)))
(defun %uninstall-class (self &key
(database *default-database*)
(owner nil))
- (drop-table (sql-expression :table (view-table self))
+ (drop-table (sql-expression :table (database-identifier self database))
:if-does-not-exist :ignore
:database database
:owner owner)
+ (database-remove-autoincrement-sequence self database)
(setf (database-view-classes database)
(remove self (database-view-classes database))))
(flet ((qfk (k)
(sql-operation '==
(sql-expression :attribute
- (view-class-slot-column k)
+ (database-identifier k database)
:table tb)
(db-value-from-slot
k
(defun generate-attribute-reference (vclass slotdef)
(cond
((eq (view-class-slot-db-kind slotdef) :base)
- (sql-expression :attribute (view-class-slot-column slotdef)
- :table (view-table vclass)))
+ (sql-expression :attribute (database-identifier slotdef nil)
+ :table (database-identifier vclass nil)))
((eq (view-class-slot-db-kind slotdef) :key)
- (sql-expression :attribute (view-class-slot-column slotdef)
- :table (view-table vclass)))
+ (sql-expression :attribute (database-identifier slotdef nil)
+ :table (database-identifier vclass nil)))
(t nil)))
;;
(push (cons slotdef res) sels))))))
sels))
+(defmethod choose-database-for-instance ((obj standard-db-object) &optional database)
+ "Determine which database connection to use for a standard-db-object.
+ Errs if none is available."
+ (or (find-if #'(lambda (db)
+ (and db (is-database-open db)))
+ (list (view-database obj)
+ database
+ *default-database*))
+ (signal-no-database-error nil)))
+
+
;; Called by 'get-slot-values-from-view'
;;
(cond ((and value (null slot-reader))
(setf (slot-value instance slot-name)
(read-sql-value value (delistify slot-type)
- (view-database instance)
+ (choose-database-for-instance instance)
(database-underlying-type
- (view-database instance)))))
+ (choose-database-for-instance instance)))))
((null value)
(update-slot-with-null instance slot-name slotdef))
((typep slot-reader 'string)
(defmethod update-record-from-slot ((obj standard-db-object) slot &key
(database *default-database*))
- (let* ((database (or (view-database obj) database))
+ (let* ((database (choose-database-for-instance obj database))
(view-class (class-of obj)))
(when (normalizedp view-class)
;; If it's normalized, find the class that actually contains
(let* ((vct (view-table view-class))
(sd (slotdef-for-slot-with-class slot view-class)))
(check-slot-type sd (slot-value obj slot))
- (let* ((att (view-class-slot-column sd))
+ (let* ((att (database-identifier sd database))
(val (db-value-from-slot sd (slot-value obj slot) database)))
(cond ((and vct sd (view-database obj))
(update-records (sql-expression :table vct)
(update-record-from-slot obj slot :database database))
(return-from update-record-from-slots (values)))
- (let* ((database (or (view-database obj) database))
+ (let* ((database (choose-database-for-instance obj database))
(vct (view-table (class-of obj)))
(sds (slotdefs-for-slots-with-class slots (class-of obj)))
(avps (mapcar #'(lambda (s)
obj (slot-definition-name s))))
(check-slot-type s val)
(list (sql-expression
- :attribute (view-class-slot-column s))
+ :attribute (database-identifier s database))
(db-value-from-slot s val database))))
sds)))
(cond ((and avps (view-database obj))
(defmethod update-records-from-instance ((obj standard-db-object)
&key database this-class)
- (let ((database (or database (view-database obj) *default-database*))
+ (let ((database (choose-database-for-instance obj database))
(pk nil))
(labels ((slot-storedp (slot)
(and (member (view-class-slot-db-kind slot) '(:base :key))
(slot-value-list (slot)
(let ((value (slot-value obj (slot-definition-name slot))))
(check-slot-type slot value)
- (list (sql-expression :attribute (view-class-slot-column slot))
+ (list (sql-expression :attribute (database-identifier slot database))
(db-value-from-slot slot value database)))))
(let* ((view-class (or this-class (class-of obj)))
(pk-slot (car (keyslots-for-class view-class)))
+ (pk-name (when pk-slot (slot-definition-name pk-slot)))
(view-class-table (view-table view-class))
(pclass (car (class-direct-superclasses view-class))))
(when (normalizedp view-class)
(setf pk (update-records-from-instance obj :database database
:this-class pclass))
(when pk-slot
- (setf (slot-value obj (slot-definition-name pk-slot)) pk)))
+ (setf (slot-value obj pk-name) pk)))
(let* ((slots (remove-if-not #'slot-storedp
(if (normalizedp view-class)
(ordered-class-direct-slots view-class)
(not record-values))
nil)
((view-database obj)
+ ;; if this slot is set, the database object was returned from a select
+ ;; and has already been in the database, so we must need an update
(update-records (sql-expression :table view-class-table)
:av-pairs record-values
:where (key-qualifier-for-instance
:database database)
(when pk-slot
(setf pk (or pk
- (slot-value obj (slot-definition-name pk-slot))))))
+ (slot-value obj pk-name)))))
(t
(insert-records :into (sql-expression :table view-class-table)
:av-pairs record-values
:database database)
-
(when (and pk-slot (not pk))
- (setf pk (if (or (member :auto-increment (listify (view-class-slot-db-constraints pk-slot)))
- (not (null (view-class-slot-autoincrement-sequence pk-slot))))
- (setf (slot-value obj (slot-definition-name pk-slot))
- (database-last-auto-increment-id database
- view-class-table
- pk-slot)))))
+ (setf pk
+ (when (auto-increment-column-p pk-slot database)
+ (setf (slot-value obj pk-name)
+ (database-last-auto-increment-id
+ database view-class-table pk-slot)))))
(when pk-slot
(setf pk (or pk
- (slot-value
- obj (slot-definition-name pk-slot)))))
- (when (eql this-class nil)
+ (and (slot-boundp obj pk-name)
+ (slot-value obj pk-name)))))
+ (when (eql this-class nil)
(setf (slot-value obj 'view-database) database)))))))
;; handle slots with defaults
(let* ((view-class (or this-class (class-of obj)))
(slots (if (normalizedp view-class)
(ordered-class-direct-slots view-class)
- (ordered-class-slots view-class))))
+ (ordered-class-slots view-class))))
(dolist (slot slots)
- (when (and (slot-exists-p slot 'db-constraints)
- (listp (view-class-slot-db-constraints slot))
- (member :default (view-class-slot-db-constraints slot)))
- (unless (and (slot-boundp obj (slot-definition-name slot))
- (slot-value obj (slot-definition-name slot)))
- (update-slot-from-record obj (slot-definition-name slot))))))
+ (let ((slot-name (slot-definition-name slot)))
+ (when (and (slot-exists-p slot 'db-constraints)
+ (listp (view-class-slot-db-constraints slot))
+ (member :default (view-class-slot-db-constraints slot)))
+ (unless (and (slot-boundp obj slot-name)
+ (slot-value obj slot-name))
+ (update-slot-from-record obj slot-name))))))
pk))
-(defmethod delete-instance-records ((instance standard-db-object))
- (let ((vt (sql-expression :table (view-table (class-of instance))))
- (vd (view-database instance)))
- (if vd
- (let ((qualifier (key-qualifier-for-instance instance :database vd)))
- (delete-records :from vt :where qualifier :database vd)
- (setf (record-caches vd) nil)
+(defmethod delete-instance-records ((instance standard-db-object) &key database)
+ (let ((database (choose-database-for-instance instance database))
+ (vt (sql-expression :table (view-table (class-of instance)))))
+ (if database
+ (let ((qualifier (key-qualifier-for-instance instance :database database)))
+ (delete-records :from vt :where qualifier :database database)
+ (setf (record-caches database) nil)
(setf (slot-value instance 'view-database) nil)
(values))
- (signal-no-database-error vd))))
+ (signal-no-database-error database))))
(defmethod update-instance-from-records ((instance standard-db-object)
&key (database *default-database*)
(setf pres (update-instance-from-records instance :database database
:this-class pclass)))
(let* ((view-table (sql-expression :table (view-table view-class)))
- (vd (or (view-database instance) database))
+ (vd (choose-database-for-instance instance database))
(view-qual (key-qualifier-for-instance instance :database vd
:this-class view-class))
(sels (generate-selection-list view-class))
(ordered-class-direct-slots this-class)))
this-class))))
(let* ((view-table (sql-expression :table (view-table view-class)))
- (vd (or (view-database instance) database))
+ (vd (choose-database-for-instance instance database))
(view-qual (key-qualifier-for-instance instance :database vd
:this-class view-class))
(att-ref (generate-attribute-reference view-class slot-def))
(sld (slotdef-for-slot-with-class slot class)))
(if sld
(if (eq value +no-slot-value+)
- (sql-expression :attribute (view-class-slot-column sld)
+ (sql-expression :attribute (database-identifier sld database)
:table (view-table class))
(db-value-from-slot
sld
:table jc-view-table))
:where jq
:result-types :auto
- :database (view-database object))))
+ :database (choose-database-for-instance object))))
(mapcar #'(lambda (i)
(let* ((instance (car i))
- (jcc (make-instance jc :view-database (view-database instance))))
+ (jcc (make-instance jc :view-database (choose-database-for-instance instance))))
(setf (slot-value jcc (gethash :foreign-key dbi))
key)
(setf (slot-value jcc (gethash :home-key tdbi))
;; just fill in minimal slots
(mapcar
#'(lambda (k)
- (let ((instance (make-instance tsc :view-database (view-database object)))
- (jcc (make-instance jc :view-database (view-database object)))
+ (let ((instance (make-instance tsc :view-database (choose-database-for-instance object)))
+ (jcc (make-instance jc :view-database (choose-database-for-instance object)))
(fk (car k)))
(setf (slot-value instance (gethash :home-key tdbi)) fk)
(setf (slot-value jcc (gethash :foreign-key dbi))
(select (sql-expression :attribute (gethash :foreign-key tdbi) :table jc-view-table)
:from (sql-expression :table jc-view-table)
:where jq
- :database (view-database object))))))))
+ :database (choose-database-for-instance object))))))))
;;; Remote Joins
(let ((jq (join-qualifier class object slot-def)))
(when jq
(select jc :where jq :flatp t :result-types nil
- :database (view-database object))))))
+ :database (choose-database-for-instance object))))))
(defun fault-join-slot (class object slot-def)
(let* ((dbi (view-class-slot-db-info slot-def))
(symbol
(sql-expression
:attribute
- (view-class-slot-column
- (slotdef-for-slot-with-class fk sc))
+ (database-identifier
+ (slotdef-for-slot-with-class fk sc) nil)
:table (view-table sc)))
(t fk))
(typecase hk
(let ((res (car (select (class-name sc) :where jq
:flatp t :result-types nil
:caching nil
- :database (view-database object))))
+ :database (choose-database-for-instance object))))
(slot-name (slot-definition-name slot-def)))
;; If current class is normalized and wanted slot is not
(symbol
(sql-expression
:attribute
- (view-class-slot-column fksd)
- :table (view-table jc)))
+ (database-identifier fksd nil)
+ :table (database-identifier jc nil)))
(t fk))
(typecase hk
(symbol
(car objects)
objects))))
+(defmethod select-table-sql-expr ((table T))
+ "Turns an object representing a table into the :from part of the sql expression that will be executed "
+ (sql-expression :table (view-table table)))
+
+
(defun find-all (view-classes
&rest args
&key all set-operation distinct from where group-by having
order-by offset limit refresh flatp result-types
inner-join on
(database *default-database*)
- instances)
+ instances parameters)
"Called by SELECT to generate object query results when the
View Classes VIEW-CLASSES are passed as arguments to SELECT."
- (declare (ignore all set-operation group-by having offset limit inner-join on))
+ (declare (ignore all set-operation group-by having offset limit inner-join on parameters)
+ (dynamic-extent args))
(flet ((ref-equal (ref1 ref2)
(string= (sql-output ref1 database)
- (sql-output ref2 database)))
- (table-sql-expr (table)
- (sql-expression :table (view-table table)))
- (tables-equal (table-a table-b)
- (when (and table-a table-b)
- (string= (string (slot-value table-a 'name))
- (string (slot-value table-b 'name))))))
- (remf args :from)
- (remf args :where)
- (remf args :flatp)
- (remf args :additional-fields)
- (remf args :result-types)
- (remf args :instances)
- (let* ((*db-deserializing* t)
- (sclasses (mapcar #'find-class view-classes))
- (immediate-join-slots
- (mapcar #'(lambda (c) (generate-retrieval-joins-list c :immediate)) sclasses))
- (immediate-join-classes
- (mapcar #'(lambda (jcs)
- (mapcar #'(lambda (slotdef)
- (find-class (gethash :join-class (view-class-slot-db-info slotdef))))
- jcs))
- immediate-join-slots))
- (immediate-join-sels (mapcar #'generate-immediate-joins-selection-list sclasses))
- (sels (mapcar #'generate-selection-list sclasses))
- (fullsels (apply #'append (mapcar #'append sels immediate-join-sels)))
- (sel-tables (collect-table-refs where))
- (tables (remove-if #'null
- (remove-duplicates
- (append (mapcar #'table-sql-expr sclasses)
- (mapcan #'(lambda (jc-list)
- (mapcar
- #'(lambda (jc) (when jc (table-sql-expr jc)))
- jc-list))
- immediate-join-classes)
- sel-tables)
- :test #'tables-equal)))
- (order-by-slots (mapcar #'(lambda (ob) (if (atom ob) ob (car ob)))
- (listify order-by)))
- (join-where nil))
-
- ;;(format t "sclasses: ~W~%ijc: ~W~%tables: ~W~%" sclasses immediate-join-classes tables)
-
- (dolist (ob order-by-slots)
- (when (and ob (not (member ob (mapcar #'cdr fullsels)
- :test #'ref-equal)))
- (setq fullsels
- (append fullsels (mapcar #'(lambda (att) (cons nil att))
- order-by-slots)))))
- (dolist (ob (listify distinct))
- (when (and (typep ob 'sql-ident)
- (not (member ob (mapcar #'cdr fullsels)
- :test #'ref-equal)))
- (setq fullsels
- (append fullsels (mapcar #'(lambda (att) (cons nil att))
- (listify ob))))))
- (mapcar #'(lambda (vclass jclasses jslots)
- (when jclasses
- (mapcar
- #'(lambda (jclass jslot)
- (let ((dbi (view-class-slot-db-info jslot)))
- (setq join-where
- (append
- (list (sql-operation '==
- (sql-expression
- :attribute (gethash :foreign-key dbi)
- :table (view-table jclass))
- (sql-expression
- :attribute (gethash :home-key dbi)
- :table (view-table vclass))))
- (when join-where (listify join-where))))))
- jclasses jslots)))
- sclasses immediate-join-classes immediate-join-slots)
- ;; Reported buggy on clsql-devel
- ;; (when where (setq where (listify where)))
- (cond
- ((and where join-where)
- (setq where (list (apply #'sql-and where join-where))))
- ((and (null where) (> (length join-where) 1))
- (setq where (list (apply #'sql-and join-where)))))
-
- (let* ((rows (apply #'select
- (append (mapcar #'cdr fullsels)
- (cons :from
- (list (append (when from (listify from))
- (listify tables))))
- (list :result-types result-types)
- (when where
- (list :where where))
- args)))
- (instances-to-add (- (length rows) (length instances)))
- (perhaps-extended-instances
- (if (plusp instances-to-add)
- (append instances (do ((i 0 (1+ i))
- (res nil))
- ((= i instances-to-add) res)
- (push (make-list (length sclasses) :initial-element nil) res)))
- instances))
- (objects (mapcar
- #'(lambda (row instance)
- (build-objects row sclasses immediate-join-classes sels
- immediate-join-sels database refresh flatp
- (if (and flatp (atom instance))
- (list instance)
- instance)))
- rows perhaps-extended-instances)))
- objects))))
+ (sql-output ref2 database))))
+ (declare (dynamic-extent (function ref-equal)))
+ (let ((args (filter-plist args :from :where :flatp :additional-fields :result-types :instances)))
+ (let* ((*db-deserializing* t)
+ (sclasses (mapcar #'find-class view-classes))
+ (immediate-join-slots
+ (mapcar #'(lambda (c) (generate-retrieval-joins-list c :immediate)) sclasses))
+ (immediate-join-classes
+ (mapcar #'(lambda (jcs)
+ (mapcar #'(lambda (slotdef)
+ (find-class (gethash :join-class (view-class-slot-db-info slotdef))))
+ jcs))
+ immediate-join-slots))
+ (immediate-join-sels (mapcar #'generate-immediate-joins-selection-list sclasses))
+ (sels (mapcar #'generate-selection-list sclasses))
+ (fullsels (apply #'append (mapcar #'append sels immediate-join-sels)))
+ (sel-tables (collect-table-refs where))
+ (tables (remove-if #'null
+ (remove-duplicates
+ (append (mapcar #'select-table-sql-expr sclasses)
+ (mapcan #'(lambda (jc-list)
+ (mapcar
+ #'(lambda (jc) (when jc (select-table-sql-expr jc)))
+ jc-list))
+ immediate-join-classes)
+ sel-tables)
+ :test #'database-identifier-equal)))
+ (order-by-slots (mapcar #'(lambda (ob) (if (atom ob) ob (car ob)))
+ (listify order-by)))
+ (join-where nil))
+
+ ;;(format t "sclasses: ~W~%ijc: ~W~%tables: ~W~%" sclasses immediate-join-classes tables)
+
+ (dolist (ob order-by-slots)
+ (when (and ob (not (member ob (mapcar #'cdr fullsels)
+ :test #'ref-equal)))
+ (setq fullsels
+ (append fullsels (mapcar #'(lambda (att) (cons nil att))
+ order-by-slots)))))
+ (dolist (ob (listify distinct))
+ (when (and (typep ob 'sql-ident)
+ (not (member ob (mapcar #'cdr fullsels)
+ :test #'ref-equal)))
+ (setq fullsels
+ (append fullsels (mapcar #'(lambda (att) (cons nil att))
+ (listify ob))))))
+ (mapcar #'(lambda (vclass jclasses jslots)
+ (when jclasses
+ (mapcar
+ #'(lambda (jclass jslot)
+ (let ((dbi (view-class-slot-db-info jslot)))
+ (setq join-where
+ (append
+ (list (sql-operation '==
+ (sql-expression
+ :attribute (gethash :foreign-key dbi)
+ :table (view-table jclass))
+ (sql-expression
+ :attribute (gethash :home-key dbi)
+ :table (view-table vclass))))
+ (when join-where (listify join-where))))))
+ jclasses jslots)))
+ sclasses immediate-join-classes immediate-join-slots)
+ ;; Reported buggy on clsql-devel
+ ;; (when where (setq where (listify where)))
+ (cond
+ ((and where join-where)
+ (setq where (list (apply #'sql-and where join-where))))
+ ((and (null where) (> (length join-where) 1))
+ (setq where (list (apply #'sql-and join-where)))))
+
+ (let* ((rows (apply #'select
+ (append (mapcar #'cdr fullsels)
+ (cons :from
+ (list (append (when from (listify from))
+ (listify tables))))
+ (list :result-types result-types)
+ (when where
+ (list :where where))
+ args)))
+ (instances-to-add (- (length rows) (length instances)))
+ (perhaps-extended-instances
+ (if (plusp instances-to-add)
+ (append instances (do ((i 0 (1+ i))
+ (res nil))
+ ((= i instances-to-add) res)
+ (push (make-list (length sclasses) :initial-element nil) res)))
+ instances))
+ (objects (mapcar
+ #'(lambda (row instance)
+ (build-objects row sclasses immediate-join-classes sels
+ immediate-join-sels database refresh flatp
+ (if (and flatp (atom instance))
+ (list instance)
+ instance)))
+ rows perhaps-extended-instances)))
+ objects)))))
(defmethod instance-refreshed ((instance standard-db-object)))
a list of lists. If FLATP is t and only one result is returned
for each record selected in the query, the results are returned
as elements of a list."
+ (multiple-value-bind (target-args qualifier-args)
+ (query-get-selections select-all-args)
+ (unless (or *default-database* (getf qualifier-args :database))
+ (signal-no-database-error nil))
- (flet ((select-objects (target-args)
- (and target-args
- (every #'(lambda (arg)
- (and (symbolp arg)
- (find-class arg nil)))
- target-args))))
- (multiple-value-bind (target-args qualifier-args)
- (query-get-selections select-all-args)
- (unless (or *default-database* (getf qualifier-args :database))
- (signal-no-database-error nil))
+ (let ((caching (getf qualifier-args :caching *default-caching*))
+ (result-types (getf qualifier-args :result-types :auto))
+ (refresh (getf qualifier-args :refresh nil))
+ (database (getf qualifier-args :database *default-database*)))
(cond
- ((select-objects target-args)
- (let ((caching (getf qualifier-args :caching *default-caching*))
- (result-types (getf qualifier-args :result-types :auto))
- (refresh (getf qualifier-args :refresh nil))
- (database (or (getf qualifier-args :database) *default-database*))
- (order-by (getf qualifier-args :order-by)))
- (remf qualifier-args :caching)
- (remf qualifier-args :refresh)
- (remf qualifier-args :result-types)
-
- ;; Add explicity table name to order-by if not specified and only
- ;; one selected table. This is required so FIND-ALL won't duplicate
- ;; the field
+ ((and target-args
+ (every #'(lambda (arg)
+ (and (symbolp arg)
+ (find-class arg nil)))
+ target-args))
+
+ (setf qualifier-args (filter-plist qualifier-args :caching :refresh :result-types))
+
+ ;; Add explicity table name to order-by if not specified and only
+ ;; one selected table. This is required so FIND-ALL won't duplicate
+ ;; the field
+ (let ((order-by (getf qualifier-args :order-by)))
(when (and order-by (= 1 (length target-args)))
(let ((table-name (view-table (find-class (car target-args))))
(order-by-list (copy-seq (listify order-by))))
(loop for i from 0 below (length order-by-list)
for id = (nth i order-by-list)
do (set-table-if-needed id)))
- (setf (getf qualifier-args :order-by) order-by-list)))
-
- (cond
- ((null caching)
- (apply #'find-all target-args
- (append qualifier-args
- (list :result-types result-types :refresh refresh))))
- (t
- (let ((cached (records-cache-results target-args qualifier-args database)))
- (cond
- ((and cached (not refresh))
- cached)
- ((and cached refresh)
- (let ((results (apply #'find-all (append (list target-args) qualifier-args `(:instances ,cached :result-types :auto :refresh ,refresh)))))
- (setf (records-cache-results target-args qualifier-args database) results)
- results))
- (t
- (let ((results (apply #'find-all target-args (append qualifier-args
- `(:result-types :auto :refresh ,refresh)))))
- (setf (records-cache-results target-args qualifier-args database) results)
- results))))))))
+ (setf (getf qualifier-args :order-by) order-by-list))))
+
+ (cond
+ ((null caching)
+ (apply #'find-all target-args :result-types result-types :refresh refresh qualifier-args))
+ (t
+ (let ((cached (records-cache-results target-args qualifier-args database)))
+ (if (and cached (not refresh))
+ cached
+ (let ((results (apply #'find-all target-args
+ :result-types :auto :refresh refresh
+ :instances cached
+ qualifier-args)))
+ (setf (records-cache-results target-args qualifier-args database) results)
+
+ results))))))
(t
(let* ((expr (apply #'make-query select-all-args))
+ (parameters (second (member :parameters select-all-args)))
(specified-types
- (mapcar #'(lambda (attrib)
- (if (typep attrib 'sql-ident-attribute)
- (let ((type (slot-value attrib 'type)))
- (if type
- type
- t))
- t))
- (slot-value expr 'selections))))
- (destructuring-bind (&key (flatp nil)
- (result-types :auto)
- (field-names t)
- (database *default-database*)
- &allow-other-keys)
- qualifier-args
- (query expr :flatp flatp
- :result-types
- ;; specifying a type for an attribute overrides result-types
- (if (some #'(lambda (x) (not (eq t x))) specified-types)
- specified-types
- result-types)
- :field-names field-names
- :database database))))))))
+ (mapcar #'(lambda (attrib)
+ (if (typep attrib 'sql-ident-attribute)
+ (let ((type (slot-value attrib 'type)))
+ (if type
+ type
+ t))
+ t))
+ (slot-value expr 'selections)))
+ (flatp (getf qualifier-args :flatp))
+ (field-names (getf qualifier-args :field-names t)))
+
+ (when parameters
+ (setf expr (command-object (sql-output expr database) parameters)))
+ (query expr :flatp flatp
+ :result-types
+ ;; specifying a type for an attribute overrides result-types
+ (if (some #'(lambda (x) (not (eq t x))) specified-types)
+ specified-types
+ result-types)
+ :field-names field-names
+ :database database)))))))
(defun compute-records-cache-key (targets qualifiers)
(list targets
(defun (setf records-cache-results) (results targets qualifiers database)
(unless (record-caches database)
(setf (record-caches database)
- (make-hash-table :test 'equal
- #+allegro :values #+allegro :weak
- #+clisp :weak #+clisp :value
- #+lispworks :weak-kind #+lispworks :value)))
- (setf (gethash (compute-records-cache-key targets qualifiers)
+ (make-weak-hash-table :test 'equal)))
+ (setf (gethash (compute-records-cache-key (copy-list targets) qualifiers)
(record-caches database)) results)
results)
#:sql-escape
#:in
+ ;; Command-object.lisp
+ #:expression
+ #:parameters
+ #:prepared-name
+ #:has-been-prepared
+ #:command-object
+ #:reset-command-object
+
;; Generic backends
#:generic-postgresql-database
#:generic-odbc-database
(in-package #:clsql-sys)
(defparameter *db-pool-max-free-connections* 4
- "Threshold of free-connections in the pool before we disconnect a
- database rather than returning it to the pool. This is really a heuristic
-that should, on avg keep the free connections about this size.")
+ "Threshold of free-connections in the pool before we disconnect a database
+ rather than returning it to the pool. NIL for no limit. This is really a
+ heuristic that should, on avg keep the free connections about this size.")
(defvar *db-pool* (make-hash-table :test #'equal))
(defvar *db-pool-lock* (make-process-lock "DB Pool lock"))
:initform (make-process-lock "Connection pool"))))
+
+
(defun acquire-from-pool (connection-spec database-type &optional pool encoding)
"Try to find a working database connection in the pool or create a new
one if needed. This performs 1 query against the DB to ensure it's still
:if-exists :new
:make-default nil
:encoding encoding)))
+ (setf (conn-pool conn) pool)
(with-process-lock ((conn-pool-lock pool) "new conection")
- (push conn (all-connections pool))
- (setf (conn-pool conn) pool))
+ (push conn (all-connections pool)))
conn)))
-(defun release-to-pool (database)
+(defun release-to-pool (database &optional (pool (conn-pool database)))
"Release a database connection to the pool. The backend will have a
chance to do cleanup."
- (let ((pool (conn-pool database)))
- (cond
- ;;We read the list of free-connections outside the lock. This
- ;;should be fine as long as that list is never dealt with
- ;;destructively (push and pop destructively modify the place,
- ;;not the list). Multiple threads getting to this test at the
- ;;same time might result in the free-connections getting
- ;;longer... meh.
- ((and *db-pool-max-free-connections*
- (>= (length (free-connections pool))
- *db-pool-max-free-connections*))
- (%pool-force-disconnect database)
- (with-process-lock ((conn-pool-lock pool) "Remove extra Conn")
- (setf (all-connections pool)
- (delete database (all-connections pool)))))
- (t
- ;;let it do cleanup
- (database-release-to-conn-pool database)
- (with-process-lock ((conn-pool-lock pool) "Release to pool")
- (push database (free-connections pool)))))))
+ (unless (conn-pool database) (setf (conn-pool database) pool))
+ (cond
+ ;;We read the list of free-connections outside the lock. This
+ ;;should be fine as long as that list is never dealt with
+ ;;destructively (push and pop destructively modify the place,
+ ;;not the list). Multiple threads getting to this test at the
+ ;;same time might result in the free-connections getting
+ ;;longer... meh.
+ ((or (and *db-pool-max-free-connections*
+ (>= (length (free-connections pool))
+ *db-pool-max-free-connections*)))
+ (%pool-force-disconnect database)
+
+ (with-process-lock ((conn-pool-lock pool) "Remove extra Conn")
+ (setf (all-connections pool)
+ (delete database (all-connections pool)))))
+ (t
+ ;;let it do cleanup
+ (database-release-to-conn-pool database)
+ (with-process-lock ((conn-pool-lock pool) "Release to pool")
+ (push database (free-connections pool))))))
(defmethod database-acquire-from-conn-pool (database)
(case (database-underlying-type database)
(defun find-or-create-connection-pool (connection-spec database-type)
"Find connection pool in hash table, creates a new connection pool
if not found"
- (with-process-lock (*db-pool-lock* "Find-or-create connection")
- (let* ((key (list connection-spec database-type))
- (conn-pool (gethash key *db-pool*)))
- (unless conn-pool
- (setq conn-pool (make-instance 'conn-pool
- :connection-spec connection-spec
- :pool-database-type database-type))
- (setf (gethash key *db-pool*) conn-pool))
- conn-pool)))
+ (let ((key (list connection-spec database-type)))
+ (with-process-lock (*db-pool-lock* "Find-or-create connection")
+ (or (gethash key *db-pool*)
+ (setf (gethash key *db-pool*)
+ (make-instance 'conn-pool
+ :connection-spec connection-spec
+ :pool-database-type database-type))))))
(defun disconnect-pooled (&optional clear)
"Disconnects all connections in the pool. When clear, also deletes
;;; Sequence functions
(defun %sequence-name-to-table (sequence-name database)
- (concatenate 'string
- (convert-to-db-default-case "_CLSQL_SEQ_" database)
- (sql-escape sequence-name)))
-
-(defun %table-name-to-sequence-name (table-name database)
- (and (>= (length table-name) 11)
- (string-equal (subseq table-name 0 11)
- (convert-to-db-default-case "_CLSQL_SEQ_" database))
- (subseq table-name 11)))
+ (escaped
+ (combine-database-identifiers
+ (list sequence-name 'CLSQL_SEQ)
+ database)))
(defmethod database-create-sequence (sequence-name database)
(let ((table-name (%sequence-name-to-table sequence-name database)))
(concatenate 'string "DROP TABLE " (%sequence-name-to-table sequence-name database))
database))
+(defun %table-name-to-sequence-name (table-name)
+ ;; if this was escaped it still should be,
+ ;; if it wasnt it still shouldnt-be
+ (check-type table-name string)
+ (replace-all table-name "_CLSQL_SEQ" ""))
+
(defmethod database-list-sequences (database &key (owner nil))
(declare (ignore owner))
(mapcan #'(lambda (s)
- (let ((sn (%table-name-to-sequence-name s database)))
- (and sn (list sn))))
+ (and (search "_CLSQL_SEQ" s :test #'string-equal)
+ (list (%table-name-to-sequence-name s))))
(database-list-tables-and-sequences database)))
(defmethod database-set-sequence-position (sequence-name position database)
(defun generate-sql-reference (&rest arglist)
(cond ((= (length arglist) 1) ; string, table or attribute
- (if (stringp (car arglist))
- (sql-expression :string (car arglist))
- (sql-expression :attribute (car arglist))))
+ (let ((arg (first arglist)))
+ (typecase arg
+ (string (sql-expression :string arg))
+ (symbol ;; handle . separated names
+ (let* ((sn (symbol-name arg))
+ (idx (position #\. sn)))
+ (cond
+ (idx (sql-expression :table (intern (subseq sn 0 idx))
+ :attribute (intern (subseq sn (+ idx 1))) ))
+ (T (sql-expression :attribute arg))))
+ ))))
((<= 2 (length arglist))
(let ((sqltype (when (keywordp (caddr arglist)) (caddr arglist) nil)))
(cond
(string
(make-instance 'sql :string string))
(attribute
- (make-instance 'sql-ident-attribute :name attribute
+ (make-instance 'sql-ident-attribute :name attribute
:qualifier (or table alias)
:type type))
((and table (not attribute))
(defun float-to-sql-string (num)
"Convert exponent character for SQL"
(let ((str (write-to-string num :readably t)))
+ (declare (type string str))
(cond
((find #\f str)
(substitute #\e #\f str))
(substitute-string-for-char s #\' "''"))
(defun substitute-string-for-char (procstr match-char subst-str)
-"Substitutes a string for a single matching character of a string"
- (let ((pos (position match-char procstr)))
- (if pos
- (concatenate 'string
- (subseq procstr 0 pos) subst-str
- (substitute-string-for-char
- (subseq procstr (1+ pos)) match-char subst-str))
- procstr)))
+ "Substitutes a string for a single matching character of a string"
+ (when procstr
+ (locally
+ (declare (type string procstr))
+ (let ((pos (position match-char procstr)))
+ (if pos
+ (concatenate 'string
+ (subseq procstr 0 pos) subst-str
+ (substitute-string-for-char
+ (subseq procstr (1+ pos)) match-char subst-str))
+ procstr)))))
(defun position-char (char string start max)
(setq pos (1+ end))))
(defun string-to-list-connection-spec (str)
+ (declare (type string str))
(let ((at-pos (position-char #\@ str 0 (length str))))
(cond
((and at-pos (> (length str) at-pos))
(eval-when (:compile-toplevel :load-toplevel :execute)
(setq cl:*features* (delete :clsql-lowercase-reader cl:*features*)))
+(defun replace-all (string part replacement &key (test #'char=) stream)
+ "Returns a new string in which all the occurences of the part
+is replaced with replacement. [FROM http://cl-cookbook.sourceforge.net/strings.html#manip]"
+ (let ((out (or stream (make-string-output-stream))))
+ (loop with part-length = (length part)
+ for old-pos = 0 then (+ pos part-length)
+ for pos = (search part string
+ :start2 old-pos
+ :test test)
+ do (write-string string out
+ :start old-pos
+ :end (or pos (length string)))
+ when pos do (write-string replacement out)
+ while pos)
+ (unless stream
+ (get-output-stream-string out))))
+
+
+(defun filter-plist (plist &rest keys-to-remove)
+ "Returns a copy of the given plist with indicated key-value pairs
+removed. keys are searched with #'MEMBER"
+ (declare (dynamic-extent keys-to-remove))
+ (when plist
+ (loop for (k v . rest) = plist then rest
+ unless (member k keys-to-remove)
+ collect k and collect v
+ while rest)))
+
+(defmacro make-weak-hash-table (&rest args)
+ "Creates a weak hash table for use in a cache."
+ `(progn
+
+ ;;NB: These are generally used for caches that may not have an alternate
+ ;;clearing mechanism. If you are on an implementation that doesn't support
+ ;;weak hash tables then you're memory may accumulate.
+
+ #-(or sbcl allegro clisp lispworks)
+ (warn "UNSAFE! use of weak hash on implementation without support. (see clsql/sql/utils.lisp to add)")
+
+ (make-hash-table
+ #+allegro :values #+allegro :weak
+ #+clisp :weak #+clisp :value
+ #+lispworks :weak-kind #+lispworks :value
+ #+sbcl :weakness #+sbcl :value
+ ,@args)
+ ))
(defun %dataset-init (name)
"Run initialization code and fill database for given dataset."
- (handler-bind
- ((error #'generic-error))
- ;;find items that looks like '(:setup ...),
+ ;;find items that looks like '(:setup ...),
;; dispatch the rest.
(let ((setup (rest (find :setup name :key #'first)))
(sqldata (rest (find :sqldata name :key #'first)))
;;presumed to be view-class objects, force them to insert.
(dolist (o objdata)
(setf (slot-value o 'clsql-sys::view-database) nil)
- (clsql-sys:update-records-from-instance o))))))
+ (clsql-sys:update-records-from-instance o)))))
(defun %dataset-cleanup (name)
"Run cleanup code associated with the given dataset."
(defpackage #:clsql-tests
(:use #:clsql #:common-lisp #:rtest)
+ (:shadowing-import-from #:clsql-sys #:%get-int )
(:export
#:run-tests
#:run-tests-append-report-file
))
nil)
(deftest :basic/bigtext/2
- (dotimes (n 10)
- (with-dataset *ds-bigtext*
- (let* ((len (random 7500))
- (str (make-string len :initial-element #\a))
- (cmd (format nil "INSERT INTO testbigtext (a) VALUES ('~a')" str)))
- (execute-command cmd)
- (let ((a (first (query "SELECT a from testbigtext"
- :flatp t :field-names nil))))
- (assert (string= str a) (str a)
- "mismatch on a. inserted: ~a returned: ~a" len (length a)))
- )))
- nil)
+ (flet ((random-char ()
+ (let ((alphabet "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ")
+ (idx (random 52)))
+ (elt alphabet idx))))
+ (dotimes (n 10)
+ (with-dataset *ds-bigtext*
+ (let* ((len (random 7500))
+ (str (coerce (make-array len
+ :initial-contents (loop repeat len collect (random-char)))
+ 'string))
+ (cmd (format nil "INSERT INTO testbigtext (a) VALUES ('~a')" str)))
+ (execute-command cmd)
+ (let ((a (first (query "SELECT a from testbigtext"
+ :flatp t :field-names nil))))
+ (assert (string= str a) (str a)
+ "mismatch on randomized bigtext(~a) inserted: ~s returned: ~s" len str a))
+ ))))
+ nil)
))
(deftest :fdml/query/1
(with-dataset *ds-employees*
(let ((count (caar (clsql:query "SELECT COUNT(*) FROM EMPLOYEE WHERE (EMAIL LIKE '%org')" :field-names nil))))
- (if (stringp count)
- (nth-value 0 (parse-integer count))
- (nth-value 0 (truncate count)))))
+ (%get-int count)))
10)
(deftest :fdml/query/2
(let ((res (clsql:query (clsql:sql [select [first-name] [sum [emplid]] :from [employee]]
[group-by [first-name]] [order-by [sum [emplid]]])
:field-names nil :result-types nil)))
- (mapcar (lambda (p) (list (car p) (truncate (read-from-string (second p)))))
+ (mapcar (lambda (p) (list (car p) (%get-int (second p))))
res)))
(("Josef" 2) ("Leon" 3) ("Nikita" 4) ("Leonid" 5) ("Yuri" 6)
("Konstantin" 7) ("Mikhail" 8) ("Boris" 9) ("Vladimir" 11)))
[select [groupid] :from [company]]])
:field-names nil :result-types nil :flatp t
)))
- (values (every #'stringp res)
- (sort (mapcar #'(lambda (f) (truncate (read-from-string f))) res)
+ (values (or (eql *test-database-type* :postgresql-socket3)
+ (every #'stringp res))
+ (sort (mapcar #'%get-int res)
#'<=))))
t (1 2 3 4 5 6 7 8 9 10))
(let ((res (car (clsql:query (clsql:sql [intersect [select [emplid] :from [employee]]
[select [groupid] :from [company]]])
:field-names nil :result-types nil :flatp t))))
- (values (stringp res)
- (nth-value 0 (truncate (read-from-string res))))))
+ (values (or (stringp res)
+ (eql *test-database-type* :postgresql-socket3))
+ (nth-value 0 (%get-int res)))))
t 1)
(deftest :fdml/query/8
(let ((res (clsql:query (clsql:sql [except [select [emplid] :from [employee]]
[select [groupid] :from [company]]])
:field-names nil :result-types nil :flatp t)))
- (values (every #'stringp res)
- (sort (mapcar #'(lambda (f) (truncate (read-from-string f))) res)
+ (values (or (every #'stringp res)
+ (eql *test-database-type* :postgresql-socket3))
+ (sort (mapcar #'%get-int res)
#'<=))))
t (2 3 4 5 6 7 8 9 10))
-
;; compare min, max and average hieghts in inches (they're quite short
;; these guys!)
(deftest :fdml/select/1
:from [employee]
:result-types nil
:flatp t)))
- (apply #'< (mapcar #'(lambda (s) (parse-integer s :junk-allowed t))
- (append min avg max)))))
+ (apply #'< (mapcar #'%get-int (append min avg max)))))
t)
(deftest :fdml/select/2
:group-by [first-name]
:order-by [first-name]
:field-names nil)))
- (mapcar (lambda (p) (list (car p) (truncate (read-from-string (second p)))))
+ (mapcar (lambda (p) (list (car p) (%get-int (second p))))
res)))
(("Boris" 1) ("Josef" 1) ("Konstantin" 1) ("Leon" 1) ("Leonid" 1)
("Mikhail" 1) ("Nikita" 1) ("Vladimir" 2) ("Yuri" 1)))
(deftest :fdml/select/6
(with-dataset *ds-employees*
(if (clsql-sys:db-type-has-fancy-math? *test-database-underlying-type*)
- (mapcar #'(lambda (s) (parse-integer s :junk-allowed t))
+ (mapcar #'%get-int
(clsql:select [function "trunc" [height]] :from [employee]
:result-types nil
:field-names nil
:flatp t))
- (mapcar #'(lambda (s) (truncate (parse-integer s :junk-allowed t)))
+ (mapcar #'%get-int
(clsql:select [height] :from [employee] :flatp t
:field-names nil :result-types nil))))
(1 1 1 1 1 1 1 1 1 1))
(let ((result (car (clsql:select [max [emplid]] :from [employee] :flatp t
:field-names nil :result-types nil))))
(values
- (stringp result)
- (nth-value 0 (truncate (read-from-string result))))))
- t 10)
+ (nth-value 0 (%get-int result)))))
+ 10)
(deftest :fdml/select/8
(with-dataset *ds-employees*
(let ((result (car (clsql:select [min [emplid]] :from [employee] :flatp t
:field-names nil :result-types nil))))
(values
- (stringp result)
- (nth-value 0 (truncate (read-from-string result))))))
- t 1)
+ (nth-value 0 (%get-int result)))))
+ 1)
(deftest :fdml/select/9
- (with-dataset *ds-employees*
- (subseq
- (car
- (clsql:select [avg [emplid]] :from [employee] :flatp t
- :field-names nil :result-types nil))
- 0 3))
- "5.5")
+ (with-dataset *ds-employees*
+ (let ((val (car (clsql:select
+ [avg [emplid]] :from [employee] :flatp t
+ :field-names nil :result-types nil))))
+ (typecase val
+ (string (subseq val 0 3))
+ (number (format nil "~,1F" val)))))
+ "5.5")
(deftest :fdml/select/10
(with-dataset *ds-employees*
(("1" "Lenin")))
(deftest :fdml/select/19
- (with-dataset *ds-employees*
- (clsql:select [emplid] :from [employee] :order-by [emplid]
- :where [between [* [emplid] 10] [* 5 10] [* 10 10]]
- :field-names nil :result-types nil :flatp t))
- ("5" "6" "7" "8" "9" "10"))
+ (with-dataset *ds-employees*
+ (mapcar
+ #'%get-int
+ (clsql:select [emplid] :from [employee] :order-by [emplid]
+ :where [between [* [emplid] 10] [* 5 10] [* 10 10]]
+ :field-names nil :result-types nil :flatp t)))
+ (5 6 7 8 9 10))
(deftest :fdml/select/20
(with-dataset *ds-employees*
+ (mapcar #'%get-int
(clsql:select [emplid] :from [employee] :order-by [emplid]
:where [not [between [* [emplid] 10] [* 5 10] [* 10 10]]]
- :field-names nil :result-types nil :flatp t))
- ("1" "2" "3" "4"))
+ :field-names nil :result-types nil :flatp t)))
+ (1 2 3 4))
(deftest :fdml/select/21
(with-dataset *ds-employees*
"Boris Yeltsin" "Vladimir Putin"))
(deftest :fdml/select/23
- (with-dataset *ds-employees*
- (clsql:select [emplid] :from [employee] :where [in [emplid] '(1 2 3 4)]
- :flatp t :order-by [emplid] :field-names nil
- :result-types nil))
- ("1" "2" "3" "4"))
+ (with-dataset *ds-employees*
+ (mapcar #'%get-int
+ (clsql:select [emplid] :from [employee] :where [in [emplid] '(1 2 3 4)]
+ :flatp t :order-by [emplid] :field-names nil
+ :result-types nil)))
+ (1 2 3 4))
(deftest :fdml/select/24
(with-dataset *ds-employees*
(deftest :fdml/select/27
(with-dataset *ds-employees*
(mapcar
- (lambda (f) (truncate (read-from-string f)))
+ #'%get-int
(clsql:select [coalesce [managerid] 10] :from [employee] :order-by [emplid]
:field-names nil :result-types nil :flatp t)))
(10 1 1 1 1 1 1 1 1 1))
(deftest :fdml/select/28
- (with-dataset *ds-employees*
- (mapcar
- (lambda (f) (truncate (read-from-string (car f))))
- (loop for column in `([*] [emplid]) collect
- (clsql:select [count column] :from [employee]
- :flatp t :result-types nil :field-names nil))))
- (10 10))
+ (with-dataset *ds-employees*
+ (loop for column in `([*] [emplid])
+ collect
+ (%get-int
+ (car
+ (clsql:select [count column] :from [employee]
+ :flatp t :result-types nil :field-names nil)))))
+ (10 10))
(deftest :fdml/select/29
(with-dataset *ds-employees*
(deftest :fdml/select/32
(with-dataset *ds-employees*
- (clsql:select [emplid] :from [employee]
- :where [= [emplid] [any [select [companyid] :from [company]]]]
- :flatp t :result-types nil :field-names nil))
- ("1"))
+ (mapcar
+ #'%get-int
+ (clsql:select [emplid] :from [employee]
+ :where [= [emplid] [any [select [companyid] :from [company]]]]
+ :flatp t :result-types nil :field-names nil)))
+ (1))
(deftest :fdml/select/33
(with-dataset *ds-employees*
(defvar *rt-oodml*)
(defvar *rt-syntax*)
(defvar *rt-time*)
+(defvar *rt-pool*)
;; Below must be set as nil since test-i18n.lisp is not loaded on all platforms.
(defvar *rt-i18n* nil)
(defun default-suites ()
"The default list of tests to run."
- (append *rt-internal* *rt-connection* *rt-basic* *rt-fddl* *rt-fdml*
+ (append *rt-connection* *rt-basic* *rt-fddl* *rt-fdml*
*rt-ooddl* *rt-oodml* *rt-syntax* *rt-time* *rt-i18n*))
+(defun internal-suites ()
+ "The default internal suites that should run without any specific backend"
+ (append *rt-internal* *rt-pool*))
+
(defvar *error-count* 0)
(defvar *error-list* nil)
(defun run-tests (&key (report-stream *standard-output*) (sexp-report-stream nil)
- (suites (default-suites)))
+ (suites (append (internal-suites) (default-suites))))
;; clear SQL-OUTPUT cache
(setq clsql-sys::*output-hash* (make-hash-table :test #'equal))
+ (setf *test-database-underlying-type* nil)
(let ((specs (read-specs))
(*report-stream* report-stream)
(*sexp-report-stream* sexp-report-stream)
(warn "Not running tests because test configuration file is missing")
(return-from run-tests :skipped))
(load-necessary-systems specs)
- (dolist (db-type +all-db-types+)
- (dolist (spec (db-type-spec db-type specs))
- (let ((*test-connection-spec* spec)
- (*test-connection-db-type* db-type))
- (do-tests-for-backend db-type spec :suites suites)))))
+ ;;run the internal suites
+ (do-tests-for-internals :suites (intersection suites (internal-suites)))
+ ;; run backend-specific tests
+ (let ((suites (intersection suites (default-suites))))
+ (when suites
+ (dolist (db-type +all-db-types+)
+ (dolist (spec (db-type-spec db-type specs))
+ (let ((*test-connection-spec* spec)
+ (*test-connection-db-type* db-type))
+ (do-tests-for-backend db-type spec :suites suites)))))))
(zerop *error-count*))
(defun load-necessary-systems (specs)
"")
))
+(defun do-tests-for-internals (&key (suites (internal-suites)))
+ (write-report-banner "Test Suite" "CLSQL Internals" *report-stream*
+ "N/A")
+ (%do-tests suites nil))
+
+(defun %do-tests (test-forms db-type)
+ (regression-test:rem-all-tests)
+ (dolist (test-form test-forms)
+ (eval test-form))
+
+ (let* ((cl:*print-right-margin* *test-report-width*)
+ (remaining (regression-test:do-tests *report-stream*)))
+ (when (regression-test:pending-tests)
+ (incf *error-count* (length remaining))))
+
+ (let ((sexp-error (list db-type
+ *test-database-underlying-type*
+ (get-universal-time)
+ (length test-forms)
+ (regression-test:pending-tests)
+ (lisp-implementation-type)
+ (lisp-implementation-version)
+ (machine-type))))
+ (when *sexp-report-stream*
+ (write sexp-error :stream *sexp-report-stream* :readably t))
+ (push sexp-error *error-list*))
+ )
+
(defun do-tests-for-backend (db-type spec &key
(suites (default-suites)) )
(test-connect-to-database db-type spec)
(write-report-banner "Test Suite" db-type *report-stream*
(database-name-from-spec spec db-type))
- (regression-test:rem-all-tests)
- (dolist (test-form test-forms)
- (eval test-form))
-
- (let* ((cl:*print-right-margin* *test-report-width*)
- (remaining (regression-test:do-tests *report-stream*)))
- (when (regression-test:pending-tests)
- (incf *error-count* (length remaining))))
-
- (let ((sexp-error (list db-type
- *test-database-underlying-type*
- (get-universal-time)
- (length test-forms)
- (regression-test:pending-tests)
- (lisp-implementation-type)
- (lisp-implementation-version)
- (machine-type))))
- (when *sexp-report-stream*
- (write sexp-error :stream *sexp-report-stream* :readably t))
- (push sexp-error *error-list*))
+ (%do-tests test-forms db-type)
(format *report-stream* "~&Tests skipped:")
(if skip-tests
:oodml/update-records/6 :oodml/update-records/7
:oodml/update-records/8 :oodml/update-records/9
:oodml/update-records/9-slots :oodml/update-records/10
- :oodml/update-records/11 :oodml/update-instance/3
+ :oodml/update-records/11 :OODML/UPDATE-RECORDS/12 :oodml/update-instance/3
:oodml/update-instance/4 :oodml/update-instance/5
:oodml/update-instance/6 :oodml/update-instance/7
:oodml/db-auto-sync/3 :oodml/db-auto-sync/4))
:time/pg/fdml/usec :time/pg/oodml/no-usec :time/pg/oodml/usec))
(push (cons test "Postgres specific test.")
skip-tests))
+ ((and (eql *test-database-type* :postgresql-socket3)
+ (clsql-sys:in test :BASIC/SELECT/2 :basic/select/3))
+ (push (cons test "Postgres-socket3 always auto types")
+ skip-tests))
+ ((and (eql *test-database-type* :postgresql-socket3)
+ (clsql-sys:in test :fdml/select/18))
+ (push (cons test "Postgres-socket3 doesnt support attribute based type coersion")
+ skip-tests))
+ ((and (eql *test-database-type* :postgresql-socket3)
+ (clsql-sys:in test :basic/map/1 :basic/map/2 :basic/map/3 :basic/map/4
+ :basic/do/1 :basic/do/2 :fdml/do-query/1 :fdml/map-query/1
+ :fdml/map-query/2 :fdml/map-query/3 :fdml/map-query/4 :fdml/loop/1
+ :fdml/loop/2 :fdml/loop/3
+ ))
+ (push (cons test "postgresql-socket3 doesnt support cursoring interface")
+ skip-tests))
((and (member *test-database-underlying-type* '(:mysql))
(clsql-sys:in test :time/cross-platform/msec
:time/cross-platform/usec/no-tz :time/cross-platform/usec/tz))
(clsql-sys::prepared-sql-to-postgresql-sql "SELECT 'FOO' FROM BAR WHERE ID='Match?''?' AND CODE=?")
"SELECT 'FOO' FROM BAR WHERE ID='Match?''?' AND CODE=$1")
+ (deftest :int/output-caching/1
+ #.(locally-enable-sql-reader-syntax)
+ ;; ensure that key generation and matching is working
+ ;; so that this table doesnt balloon (more than designed)
+ (list
+ (progn (clsql:sql [foo])
+ (clsql:sql [foo])
+ (hash-table-count clsql-sys::*output-hash*))
+
+ (progn (clsql:sql [foo.bar])
+ (clsql:sql [foo bar])
+ (hash-table-count clsql-sys::*output-hash*))
+ (progn (clsql:sql (clsql-sys:sql-expression
+ :table (clsql-sys::database-identifier 'foo)
+ :attribute (clsql-sys::database-identifier 'bar)))
+ (clsql:sql (clsql-sys:sql-expression
+ :table (clsql-sys::database-identifier 'foo)
+ :attribute (clsql-sys::database-identifier 'bar)))
+ (hash-table-count clsql-sys::*output-hash*)))
+ (1 2 2))
+
+ (deftest :int/output-caching/2
+ #.(locally-enable-sql-reader-syntax)
+ ;; ensure that we can disable the output cache and
+ ;; still have everything work
+ (let ((clsql-sys::*output-hash*))
+ (list (clsql:sql [foo]) (clsql:sql [foo]) (clsql:sql [foo.bar])))
+ ("FOO" "FOO" "FOO.BAR"))
+
))
;; and stick a value in there.
(progn (clsql-sys:create-view-from-class 'big)
(values
- (clsql:table-exists-p [big] :owner *test-database-user*)
+ (clsql:table-exists-p [big] )
(progn
(clsql:drop-table [big] :if-does-not-exist :ignore)
- (clsql:table-exists-p [big] :owner *test-database-user*)))
+ (clsql:table-exists-p [big] )))
)
t nil)
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: test-pool.lisp
+;;;; Purpose: Tests for connection pools
+;;;; Author: Ryan Davis
+;;;; Created: June 27 2011
+;;;;
+;;;; This file, part of CLSQL, is Copyright (c) 2004-2010 by Kevin M. Rosenberg
+;;;;
+;;;; 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-tests)
+
+;; setup a dummy database for the pool to use
+(pushnew :dummy clsql-sys:*loaded-database-types*)
+(defclass dummy-database (clsql-sys:database) ()
+ (:default-initargs :database-type :dummy))
+(defmethod clsql-sys:database-connect (connection-spec (database-type (eql :dummy)))
+ (let ((db (make-instance 'dummy-database :connection-spec connection-spec)))
+ (setf (slot-value db 'clsql-sys::state) :open)
+ db))
+(defmethod clsql-sys::database-name-from-spec (connection-spec (database-type (eql :dummy)))
+ "dummy")
+(defmethod clsql-sys::database-acquire-from-conn-pool ((db dummy-database)) T)
+
+(setq *rt-pool*
+ '(
+ (deftest :pool/acquire
+ (let ((pool (clsql-sys::find-or-create-connection-pool nil :dummy))
+ dbx res)
+ (clsql-sys::clear-conn-pool pool)
+ (flet ((test-result (x) (push x res)))
+ (test-result (length (clsql-sys::all-connections pool)))
+ (test-result (length (clsql-sys::free-connections pool)))
+
+ (clsql-sys:with-database (db nil :database-type :dummy :pool T)
+ (test-result (not (null db)))
+ (test-result (length (clsql-sys::all-connections pool)))
+ (test-result (length (clsql-sys::free-connections pool)))
+ (setf dbx db))
+ (test-result (length (clsql-sys::all-connections pool)))
+ (test-result (length (clsql-sys::free-connections pool)))
+ (clsql-sys:with-database (db nil :database-type :dummy :pool T)
+ (test-result (eq db dbx)))
+ )
+ (nreverse res))
+ (0 0 T 1 0 1 1 T)
+ )
+
+ (deftest :pool/max-free-connections
+ (let ((pool (clsql-sys::find-or-create-connection-pool nil :dummy)))
+ (flet ((run (max-free dbs-to-release)
+ (let ((clsql-sys:*db-pool-max-free-connections* max-free)
+ dbs)
+ (clsql-sys::clear-conn-pool pool)
+ (dotimes (i dbs-to-release dbs)
+ (push (clsql-sys:connect nil :database-type :dummy
+ :pool T :if-exists :new)
+ dbs))
+ (list (length (clsql-sys::all-connections pool))
+ (progn
+ (dolist (db dbs) (clsql-sys:disconnect :database db))
+ (length (clsql-sys::free-connections pool))
+ )))))
+ (append
+ (run 5 10)
+ (run nil 10))))
+ (10 5 10 10)
+ )
+
+
+
+ (deftest :pool/find-or-create-connection-pool
+ (let ((p (clsql-sys::find-or-create-connection-pool nil :dummy)))
+ (values (null p)
+ (eq p (clsql-sys::find-or-create-connection-pool nil :dummy))
+ (eq p (clsql-sys::find-or-create-connection-pool :spec :dummy))))
+ nil T nil)
+
+ ))
(in-package #:clsql-tests)
+(defun %get-int (v)
+ (etypecase v
+ (string (parse-integer v :junk-allowed t))
+ (integer v)
+ (number (truncate v))))
+
(defvar *config-pathname*
(make-pathname :defaults (user-homedir-pathname)
:name ".clsql-test"
:type "config"))
(defvar +all-db-types+
- '(:postgresql :postgresql-socket :mysql :sqlite :sqlite3 :odbc :oracle
+ '(:postgresql :postgresql-socket :postgresql-socket3 :mysql :sqlite :sqlite3 :odbc :oracle
#+allegro :aodbc))
(defclass conn-specs ()
(mysql :accessor mysql-spec :initform nil)
(postgresql :accessor postgresql-spec :initform nil)
(postgresql-socket :accessor postgresql-socket-spec :initform nil)
+ (postgresql-socket3 :accessor postgresql-socket3-spec :initform nil)
(sqlite :accessor sqlite-spec :initform nil)
(sqlite3 :accessor sqlite3-spec :initform nil)
(odbc :accessor odbc-spec :initform nil)
projects / clsql.git / commitdiff