+24 May 2004: Marcus Pearce (m.t.pearce@city.ac.uk)
+ * db-postgresql-socket/postgresql-socket-sql.lisp: replace
+ CLSQL-SIMPLE-WARNING with SQL-WARNING.
+ * db-sqlite/sqlite-sql.lisp: replace CLSQL-SIMPLE-WARNING with
+ SQL-WARNING.
+ * db-aodbc/aodbc-sql.lisp: replace CLSQL-ERROR with SQL-ERROR.
+ * clsql.asd: reworked module structure in package definition and
+ file names to better reflect component functionality.
+ * sql/package.lisp: added SQL-FATAL-ERROR and SQL-TIMEOUT-ERROR to
+ exports list. Removed duplicate and obsolete exports. Exported
+ remaining SQL operations: SQL-SOME, SQL-<>, SQL-BETWEEN, SQL-DISTINCT,
+ SQL-NVL and SQL-FUNCTION. Organised exports by functionality/file and
+ according to whether they are specified by CommonSQL or CLSQL
+ extensions.
+ * sql/transaction.lisp: replace CLSQL-SIMPLE-WARNING with
+ SQL-WARNING.
+ * sql/generics.lisp: moved generics for QUERY and EXECUTE-COMMAND
+ here from basic-sql.lisp.
+ * sql/expressions.lisp: NEW FILE: renamed from classes.lisp (deleted).
+ * sql/fddl.lisp: NEW FILE: renamed from table.lisp (deleted).
+ * sql/fdml.lisp: NEW FILE: merger of basic-sql.lisp and sql.lisp
+ (both deleted).
+ * sql/ooddl.lisp: NEW FILE: ooddl from objects.lisp (deleted).
+ * sql/oodml.lisp: NEW FILE: oodml from objects.lisp (deleted).
+
23 May 2004 Kevin Rosenberg
* Version 2.10.22 released
* sql/kmr-mop.lisp, sql/objects.lisp: Since SBCL is the only implementation that
:components
((:file "cmucl-compat")
(:file "package")
- (:file "utils" :depends-on ("package" "db-interface"))
+ (:file "kmr-mop" :depends-on ("package"))
(:file "base-classes" :depends-on ("package"))
- (:file "conditions" :depends-on ("base-classes"))
- (:file "db-interface" :depends-on ("conditions"))
- (:file "initialize" :depends-on ("db-interface" "utils"))
- (:file "loop-extension" :depends-on ("db-interface"))
- (:file "time" :depends-on ("package"))
+ (:file "conditions" :depends-on ("base-classes"))
+ (:file "db-interface" :depends-on ("conditions"))
+ (:file "time" :depends-on ("package" "conditions"))
+ (:file "utils" :depends-on ("package" "db-interface"))
+ (:file "generics" :depends-on ("package"))))
+ (:module :database
+ :pathname ""
+ :components
+ ((:file "initialize")
(:file "database" :depends-on ("initialize"))
- (:file "recording" :depends-on ("time" "database"))
- (:file "basic-sql" :depends-on ("database" "cmucl-compat"))
- (:file "pool" :depends-on ("basic-sql"))
- (:file "transaction" :depends-on ("basic-sql"))
- (:file "kmr-mop" :depends-on ("package"))))
- (:module :core
+ (:file "recording" :depends-on ("database"))
+ (:file "pool"))
+ :depends-on (:base))
+ (:module :syntax
:pathname ""
- :components ((:file "generics")
- (:file "classes" :depends-on ("generics"))
- (:file "operations" :depends-on ("classes"))
+ :components ((:file "expressions")
+ (:file "operations"
+ :depends-on ("expressions"))
(:file "syntax" :depends-on ("operations")))
- :depends-on (:base))
+ :depends-on (:database))
(:module :functional
:pathname ""
- :components ((:file "sql")
- (:file "table" :depends-on ("sql")))
- :depends-on (:core))
+ :components ((:file "fdml")
+ (:file "transaction" :depends-on ("fdml"))
+ (:file "loop-extension"
+ :depends-on ("fdml"))
+ (:file "fddl" :depends-on ("fdml")))
+ :depends-on (:syntax))
(:module :object
:pathname ""
:components ((:file "metaclasses")
- (:file "objects" :depends-on ("metaclasses")))
+ (:file "ooddl" :depends-on ("metaclasses"))
+ (:file "oodml" :depends-on ("ooddl")))
:depends-on (:functional))
(:module :generic
:pathname ""
(dbi:connect :user user
:password password
:data-source-name dsn))
- (clsql-error (e)
+ (sql-error (e)
(error e))
(error () ;; Init or Connect failed
(error 'sql-connection-error
(handler-case
(handler-bind ((postgresql-warning
(lambda (c)
- (warn 'clsql-simple-warning
+ (warn 'sql-warning
:format-control "~A"
:format-arguments
(list (princ-to-string c))))))
(sqlite:sqlite-get-table (sqlite-db database) sql-expression)
(sqlite:sqlite-free-table data)
(unless (= row-n 0)
- (error 'clsql-simple-warning
+ (error 'sql-warning
:format-control
"Result set not empty: ~@(~A~) row~:P, ~@(~A~) column~:P "
:format-arguments (list row-n col-n))))
"<unbound>")
(database-state object))))
-
+(setf (documentation 'database-name 'function)
+ "Returns the name of a database.")
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;;
-;;;; $Id$
-;;;;
-;;;; Base SQL functions
-;;;;
-;;;; This file is part of CLSQL.
-;;;;
-;;;; CLSQL users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(in-package #:clsql-sys)
-
-;;; Query
-
-(defgeneric query (query-expression &key database result-types flatp field-names)
- (:documentation
- "Executes the SQL query expression QUERY-EXPRESSION, which may
-be an SQL expression or a string, on the supplied DATABASE which
-defaults to *DEFAULT-DATABASE*. RESULT-TYPES is a list of symbols
-which specifies the lisp type for each field returned by
-QUERY-EXPRESSION. If RESULT-TYPES is nil all results are returned
-as strings whereas the default value of :auto means that the lisp
-types are automatically computed for each field. FIELD-NAMES is t
-by default which means that the second value returned is a list
-of strings representing the columns selected by
-QUERY-EXPRESSION. If FIELD-NAMES is nil, the list of column names
-is not returned as a second value. FLATP has a default value of
-nil which means that the results are returned as a list of
-lists. If FLATP is t and only one result is returned for each
-record selected by QUERY-EXPRESSION, the results are returned as
-elements of a list."))
-
-(defmethod query ((query-expression string) &key (database *default-database*)
- (result-types :auto) (flatp nil) (field-names t))
- (record-sql-command query-expression database)
- (multiple-value-bind (rows names)
- (database-query query-expression database result-types field-names)
- (let ((result (if (and flatp (= 1 (length (car rows))))
- (mapcar #'car rows)
- rows)))
- (record-sql-result result database)
- (if field-names
- (values result names)
- result))))
-
-;;; Execute
-
-(defgeneric execute-command (expression &key database)
- (:documentation
- "Executes the SQL command EXPRESSION, which may be an SQL
-expression or a string representing any SQL statement apart from
-a query, on the supplied DATABASE which defaults to
-*DEFAULT-DATABASE*."))
-
-(defmethod execute-command ((sql-expression string)
- &key (database *default-database*))
- (record-sql-command sql-expression database)
- (let ((res (database-execute-command sql-expression database)))
- (record-sql-result res database))
- (values))
-
-;;; Large objects support
-
-(defun create-large-object (&key (database *default-database*))
- "Creates a new large object in the database and returns the object identifier"
- (database-create-large-object database))
-
-(defun write-large-object (object-id data &key (database *default-database*))
- "Writes data to the large object"
- (database-write-large-object object-id data database))
-
-(defun read-large-object (object-id &key (database *default-database*))
- "Reads the large object content"
- (database-read-large-object object-id database))
-
-(defun delete-large-object (object-id &key (database *default-database*))
- "Deletes the large object in the database"
- (database-delete-large-object object-id database))
-
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;;
-;;;; $Id$
-;;;;
-;;;; Classes defining SQL expressions and methods for formatting the
-;;;; appropriate SQL commands.
-;;;;
-;;;; This file is part of CLSQL.
-;;;;
-;;;; CLSQL users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(in-package #:clsql-sys)
-
-(defvar +empty-string+ "''")
-
-(defvar +null-string+ "NULL")
-
-(defvar *sql-stream* nil
- "stream which accumulates SQL output")
-
-(defun sql-output (sql-expr &optional database)
- (progv '(*sql-stream*)
- `(,(make-string-output-stream))
- (output-sql sql-expr database)
- (get-output-stream-string *sql-stream*)))
-
-
-(defclass %sql-expression ()
- ())
-
-(defmethod output-sql ((expr %sql-expression) database)
- (declare (ignore database))
- (write-string +null-string+ *sql-stream*))
-
-(defmethod print-object ((self %sql-expression) stream)
- (print-unreadable-object
- (self stream :type t)
- (write-string (sql-output self) stream)))
-
-;; For straight up strings
-
-(defclass sql (%sql-expression)
- ((text
- :initarg :string
- :initform ""))
- (:documentation "A literal SQL expression."))
-
-(defmethod make-load-form ((sql sql) &optional environment)
- (declare (ignore environment))
- (with-slots (text)
- sql
- `(make-instance 'sql :string ',text)))
-
-(defmethod output-sql ((expr sql) database)
- (declare (ignore database))
- (write-string (slot-value expr 'text) *sql-stream*)
- t)
-
-(defmethod print-object ((ident sql) stream)
- (format stream "#<~S \"~A\">"
- (type-of ident)
- (sql-output ident nil)))
-
-;; For SQL Identifiers of generic type
-(defclass sql-ident (%sql-expression)
- ((name
- :initarg :name
- :initform "NULL"))
- (:documentation "An SQL identifer."))
-
-(defmethod make-load-form ((sql sql-ident) &optional environment)
- (declare (ignore environment))
- (with-slots (name)
- sql
- `(make-instance 'sql-ident :name ',name)))
-
-(defvar *output-hash* (make-hash-table :test #'equal))
-
-(defmethod output-sql-hash-key (expr database)
- (declare (ignore expr database))
- nil)
-
-#+ignore
-(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)))))
-
-(defmethod output-sql ((expr sql-ident) database)
- (with-slots (name) expr
- (write-string
- (convert-to-db-default-case
- (etypecase name
- (string name)
- (symbol (symbol-name name)))
- database)
- *sql-stream*))
- t)
-
-;; For SQL Identifiers for attributes
-
-(defclass sql-ident-attribute (sql-ident)
- ((qualifier
- :initarg :qualifier
- :initform "NULL")
- (type
- :initarg :type
- :initform "NULL"))
- (:documentation "An SQL Attribute identifier."))
-
-(defmethod collect-table-refs (sql)
- (declare (ignore sql))
- nil)
-
-(defmethod collect-table-refs ((sql sql-ident-attribute))
- (let ((qual (slot-value sql 'qualifier)))
- (if (and qual (symbolp (slot-value sql 'qualifier)))
- (list (make-instance 'sql-ident-table :name
- (slot-value sql 'qualifier))))))
-
-(defmethod make-load-form ((sql sql-ident-attribute) &optional environment)
- (declare (ignore environment))
- (with-slots (qualifier type name)
- sql
- `(make-instance 'sql-ident-attribute :name ',name
- :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
- ;; Honor care of name
- (string
- (write-string name *sql-stream*))
- (symbol
- (write-string (sql-escape (convert-to-db-default-case
- (symbol-name name) database)) *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
- (convert-to-db-default-case (sql-escape qualifier) database))
- (sql-escape (convert-to-db-default-case name database))
- (when type
- (convert-to-db-default-case (symbol-name type) database)))
- (format *sql-stream* "~@[~A.~]~A"
- (when qualifier
- (typecase qualifier
- (string (format nil "~s" qualifier))
- (t (convert-to-db-default-case (sql-escape qualifier)
- database))))
- (sql-escape (convert-to-db-default-case name database))))
- t))
-
-(defmethod output-sql-hash-key ((expr sql-ident-attribute) database)
- (declare (ignore database))
- (with-slots (qualifier name type)
- expr
- (list 'sql-ident-attribute qualifier name type)))
-
-;; For SQL Identifiers for tables
-(defclass sql-ident-table (sql-ident)
- ((alias
- :initarg :table-alias :initform nil))
- (:documentation "An SQL table identifier."))
-
-(defmethod make-load-form ((sql sql-ident-table) &optional environment)
- (declare (ignore environment))
- (with-slots (alias name)
- sql
- `(make-instance 'sql-ident-table :name ',name :table-alias ',alias)))
-
-(defun generate-sql (expr database)
- (let ((*sql-stream* (make-string-output-stream)))
- (output-sql expr database)
- (get-output-stream-string *sql-stream*)))
-
-(defmethod output-sql ((expr sql-ident-table) database)
- (with-slots (name alias)
- expr
- (if (null alias)
- (write-string (sql-escape (convert-to-db-default-case (symbol-name name) database)) *sql-stream*)
- (progn
- (write-string (sql-escape (convert-to-db-default-case (symbol-name name) database)) *sql-stream*)
- (write-char #\Space *sql-stream*)
- (format *sql-stream* "~s" alias))))
- t)
-
-#|
-(defmethod database-output-sql ((self duration) database)
- (declare (ignore database))
- (format nil "'~a'" (duration-timestring self)))
-
-(defmethod database-output-sql ((self money) database)
- (database-output-sql (slot-value self 'odcl::units) database))
-|#
-
-
-(defmethod output-sql-hash-key ((expr sql-ident-table) database)
- (declare (ignore database))
- (with-slots (name alias)
- expr
- (list 'sql-ident-table name alias)))
-
-(defclass sql-relational-exp (%sql-expression)
- ((operator
- :initarg :operator
- :initform nil)
- (sub-expressions
- :initarg :sub-expressions
- :initform nil))
- (:documentation "An SQL relational expression."))
-
-(defmethod collect-table-refs ((sql sql-relational-exp))
- (let ((tabs nil))
- (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))))))
-
-
-
-
-;; Write SQL for relational operators (like 'AND' and 'OR').
-;; should do arity checking of subexpressions
-
-(defmethod output-sql ((expr sql-relational-exp) database)
- (with-slots (operator sub-expressions)
- expr
- (let ((subs (if (consp (car sub-expressions))
- (car sub-expressions)
- sub-expressions)))
- (write-char #\( *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-char #\Space *sql-stream*))
- (write-char #\) *sql-stream*)))
- t)
-
-(defclass sql-upcase-like (sql-relational-exp)
- ()
- (:documentation "An SQL 'like' that upcases its arguments."))
-
-;; Write SQL for relational operators (like 'AND' and 'OR').
-;; should do arity checking of subexpressions
-
-(defmethod output-sql ((expr sql-upcase-like) database)
- (flet ((write-term (term)
- (write-string "upper(" *sql-stream*)
- (output-sql term database)
- (write-char #\) *sql-stream*)))
- (with-slots (sub-expressions)
- expr
- (let ((subs (if (consp (car sub-expressions))
- (car sub-expressions)
- sub-expressions)))
- (write-char #\( *sql-stream*)
- (do ((sub subs (cdr sub)))
- ((null (cdr sub)) (write-term (car sub)))
- (write-term (car sub))
- (write-string " LIKE " *sql-stream*))
- (write-char #\) *sql-stream*))))
- t)
-
-(defclass sql-assignment-exp (sql-relational-exp)
- ()
- (:documentation "An SQL Assignment expression."))
-
-
-(defmethod output-sql ((expr sql-assignment-exp) database)
- (with-slots (operator sub-expressions)
- expr
- (do ((sub sub-expressions (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-char #\Space *sql-stream*)))
- t)
-
-(defclass sql-value-exp (%sql-expression)
- ((modifier
- :initarg :modifier
- :initform nil)
- (components
- :initarg :components
- :initform nil))
- (:documentation
- "An SQL value expression.")
- )
-
-(defmethod collect-table-refs ((sql sql-value-exp))
- (let ((tabs nil))
- (if (listp (slot-value sql 'components))
- (progn
- (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)))))
- nil)))
-
-
-
-(defmethod output-sql ((expr sql-value-exp) database)
- (with-slots (modifier components)
- expr
- (if modifier
- (progn
- (write-char #\( *sql-stream*)
- (output-sql modifier database)
- (write-char #\Space *sql-stream*)
- (output-sql components database)
- (write-char #\) *sql-stream*))
- (output-sql components database))))
-
-(defclass sql-typecast-exp (sql-value-exp)
- ()
- (:documentation "An SQL typecast expression."))
-
-(defmethod output-sql ((expr sql-typecast-exp) database)
- (database-output-sql expr database))
-
-(defmethod database-output-sql ((expr sql-typecast-exp) database)
- (with-slots (components)
- expr
- (output-sql components database)))
-
-
-(defmethod collect-table-refs ((sql sql-typecast-exp))
- (when (slot-value sql 'components)
- (collect-table-refs (slot-value sql 'components))))
-
-(defclass sql-function-exp (%sql-expression)
- ((name
- :initarg :name
- :initform nil)
- (args
- :initarg :args
- :initform nil))
- (:documentation
- "An SQL function expression."))
-
-(defmethod collect-table-refs ((sql sql-function-exp))
- (let ((tabs nil))
- (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))))))
-
-(defmethod output-sql ((expr sql-function-exp) database)
- (with-slots (name args)
- expr
- (output-sql name database)
- (when args (output-sql args database)))
- t)
-
-
-(defclass sql-between-exp (sql-function-exp)
- ()
- (:documentation "An SQL between expression."))
-
-(defmethod output-sql ((expr sql-between-exp) database)
- (with-slots (name args)
- expr
- (output-sql (first args) database)
- (write-string " BETWEEN " *sql-stream*)
- (output-sql (second args) database)
- (write-string " AND " *sql-stream*)
- (output-sql (third args) database))
- t)
-
-(defclass sql-query-modifier-exp (%sql-expression)
- ((modifier :initarg :modifier :initform nil)
- (components :initarg :components :initform nil))
- (:documentation "An SQL query modifier expression."))
-
-(defmethod output-sql ((expr sql-query-modifier-exp) database)
- (with-slots (modifier components)
- expr
- (output-sql modifier database)
- (write-string " " *sql-stream*)
- (output-sql (car components) database)
- (when components
- (mapc #'(lambda (comp)
- (write-string ", " *sql-stream*)
- (output-sql comp database))
- (cdr components))))
- t)
-
-(defclass sql-set-exp (%sql-expression)
- ((operator
- :initarg :operator
- :initform nil)
- (sub-expressions
- :initarg :sub-expressions
- :initform nil))
- (:documentation "An SQL set expression."))
-
-(defmethod collect-table-refs ((sql sql-set-exp))
- (let ((tabs nil))
- (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))))))
-
-(defmethod output-sql ((expr sql-set-exp) database)
- (with-slots (operator sub-expressions)
- expr
- (let ((subs (if (consp (car sub-expressions))
- (car sub-expressions)
- sub-expressions)))
- (when (= (length subs) 1)
- (output-sql 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-char #\Space *sql-stream*))))
- t)
-
-(defclass sql-query (%sql-expression)
- ((selections
- :initarg :selections
- :initform nil)
- (all
- :initarg :all
- :initform nil)
- (flatp
- :initarg :flatp
- :initform nil)
- (set-operation
- :initarg :set-operation
- :initform nil)
- (distinct
- :initarg :distinct
- :initform nil)
- (from
- :initarg :from
- :initform nil)
- (where
- :initarg :where
- :initform nil)
- (group-by
- :initarg :group-by
- :initform nil)
- (having
- :initarg :having
- :initform nil)
- (limit
- :initarg :limit
- :initform nil)
- (offset
- :initarg :offset
- :initform nil)
- (order-by
- :initarg :order-by
- :initform nil)
- (inner-join
- :initarg :inner-join
- :initform nil)
- (on
- :initarg :on
- :initform nil))
- (:documentation "An SQL SELECT query."))
-
-(defclass sql-object-query (%sql-expression)
- ((objects
- :initarg :objects
- :initform nil)
- (flatp
- :initarg :flatp
- :initform nil)
- (exp
- :initarg :exp
- :initform nil)
- (refresh
- :initarg :refresh
- :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)))))
-
-(defvar *select-arguments*
- '(:all :database :distinct :flatp :from :group-by :having :order-by
- :set-operation :where :offset :limit :inner-join :on
- ;; below keywords are not a SQL argument, but these keywords may terminate select
- :caching :refresh))
-
-(defun query-arg-p (sym)
- (member sym *select-arguments*))
-
-(defun query-get-selections (select-args)
- "Return two values: the list of select-args up to the first keyword,
-uninclusive, and the args from that keyword to the end."
- (let ((first-key-arg (position-if #'query-arg-p select-args)))
- (if first-key-arg
- (values (subseq select-args 0 first-key-arg)
- (subseq select-args first-key-arg))
- select-args)))
-
-(defun make-query (&rest args)
- (flet ((select-objects (target-args)
- (and target-args
- (every #'(lambda (arg)
- (and (symbolp arg)
- (find-class arg nil)))
- target-args))))
- (multiple-value-bind (selections arglist)
- (query-get-selections args)
- (if (select-objects selections)
- (destructuring-bind (&key flatp refresh &allow-other-keys) arglist
- (make-instance 'sql-object-query :objects selections
- :flatp flatp :refresh refresh
- :exp arglist))
- (destructuring-bind (&key all flatp set-operation distinct from where
- group-by having order-by
- offset limit inner-join on &allow-other-keys)
- arglist
- (if (null selections)
- (error "No target columns supplied to select statement."))
- (if (null from)
- (error "No source tables supplied to select statement."))
- (make-instance 'sql-query :selections selections
- :all all :flatp flatp :set-operation set-operation
- :distinct distinct :from from :where where
- :limit limit :offset offset
- :group-by group-by :having having :order-by order-by
- :inner-join inner-join :on on))))))
-
-(defvar *in-subselect* nil)
-
-(defmethod output-sql ((query sql-query) database)
- (with-slots (distinct selections from where group-by having order-by
- limit offset inner-join on all set-operation)
- query
- (when *in-subselect*
- (write-string "(" *sql-stream*))
- (write-string "SELECT " *sql-stream*)
- (when all
- (write-string "ALL " *sql-stream*))
- (when (and distinct (not all))
- (write-string "DISTINCT " *sql-stream*)
- (unless (eql t distinct)
- (write-string "ON " *sql-stream*)
- (output-sql distinct database)
- (write-char #\Space *sql-stream*)))
- (output-sql (apply #'vector selections) database)
- (when from
- (write-string " FROM " *sql-stream*)
- (typecase from
- (list (output-sql (apply #'vector from) database))
- (string (write-string from *sql-stream*))
- (t (output-sql from database))))
- (when inner-join
- (write-string " INNER JOIN " *sql-stream*)
- (output-sql inner-join database))
- (when on
- (write-string " ON " *sql-stream*)
- (output-sql on database))
- (when where
- (write-string " WHERE " *sql-stream*)
- (let ((*in-subselect* t))
- (output-sql where database)))
- (when group-by
- (write-string " GROUP BY " *sql-stream*)
- (output-sql group-by database))
- (when having
- (write-string " HAVING " *sql-stream*)
- (output-sql having database))
- (when order-by
- (write-string " ORDER BY " *sql-stream*)
- (if (listp order-by)
- (do ((order order-by (cdr order)))
- ((null order))
- (let ((item (car order)))
- (typecase item
- (cons
- (output-sql (car item) database)
- (format *sql-stream* " ~A" (cadr item)))
- (t
- (output-sql item database)))
- (when (cdr order)
- (write-char #\, *sql-stream*))))
- (output-sql order-by database)))
- (when limit
- (write-string " LIMIT " *sql-stream*)
- (output-sql limit database))
- (when offset
- (write-string " OFFSET " *sql-stream*)
- (output-sql offset database))
- (when *in-subselect*
- (write-string ")" *sql-stream*))
- (when set-operation
- (write-char #\Space *sql-stream*)
- (output-sql set-operation database)))
- t)
-
-(defmethod output-sql ((query sql-object-query) database)
- (declare (ignore database))
- (with-slots (objects)
- query
- (when objects
- (format *sql-stream* "(~{~A~^ ~})" objects))))
-
-
-;; INSERT
-
-(defclass sql-insert (%sql-expression)
- ((into
- :initarg :into
- :initform nil)
- (attributes
- :initarg :attributes
- :initform nil)
- (values
- :initarg :values
- :initform nil)
- (query
- :initarg :query
- :initform nil))
- (:documentation
- "An SQL INSERT statement."))
-
-(defmethod output-sql ((ins sql-insert) database)
- (with-slots (into attributes values query)
- ins
- (write-string "INSERT INTO " *sql-stream*)
- (output-sql
- (typecase into
- (string (sql-expression :attribute into))
- (t into))
- database)
- (when attributes
- (write-char #\Space *sql-stream*)
- (output-sql attributes database))
- (when values
- (write-string " VALUES " *sql-stream*)
- (output-sql values database))
- (when query
- (write-char #\Space *sql-stream*)
- (output-sql query database)))
- t)
-
-;; DELETE
-
-(defclass sql-delete (%sql-expression)
- ((from
- :initarg :from
- :initform nil)
- (where
- :initarg :where
- :initform nil))
- (:documentation
- "An SQL DELETE statement."))
-
-(defmethod output-sql ((stmt sql-delete) database)
- (with-slots (from where)
- stmt
- (write-string "DELETE FROM " *sql-stream*)
- (typecase from
- (symbol (write-string (sql-escape from) *sql-stream*))
- (t (output-sql from database)))
- (when where
- (write-string " WHERE " *sql-stream*)
- (output-sql where database)))
- t)
-
-;; UPDATE
-
-(defclass sql-update (%sql-expression)
- ((table
- :initarg :table
- :initform nil)
- (attributes
- :initarg :attributes
- :initform nil)
- (values
- :initarg :values
- :initform nil)
- (where
- :initarg :where
- :initform nil))
- (:documentation "An SQL UPDATE statement."))
-
-(defmethod output-sql ((expr sql-update) database)
- (with-slots (table where attributes values)
- expr
- (flet ((update-assignments ()
- (mapcar #'(lambda (a b)
- (make-instance 'sql-assignment-exp
- :operator '=
- :sub-expressions (list a b)))
- attributes values)))
- (write-string "UPDATE " *sql-stream*)
- (output-sql table database)
- (write-string " SET " *sql-stream*)
- (output-sql (apply #'vector (update-assignments)) database)
- (when where
- (write-string " WHERE " *sql-stream*)
- (output-sql where database))))
- t)
-
-;; CREATE TABLE
-
-(defclass sql-create-table (%sql-expression)
- ((name
- :initarg :name
- :initform nil)
- (columns
- :initarg :columns
- :initform nil)
- (modifiers
- :initarg :modifiers
- :initform nil)
- (transactions
- :initarg :transactions
- :initform nil))
- (:documentation
- "An SQL CREATE TABLE statement."))
-
-;; Here's a real warhorse of a function!
-
-(declaim (inline listify))
-(defun listify (x)
- (if (atom x)
- (list x)
- x))
-
-(defmethod output-sql ((stmt sql-create-table) database)
- (flet ((output-column (column-spec)
- (destructuring-bind (name type &optional db-type &rest constraints)
- column-spec
- (let ((type (listify type)))
- (output-sql name database)
- (write-char #\Space *sql-stream*)
- (write-string
- (if (stringp db-type) db-type ; override definition
- (database-get-type-specifier (car type) (cdr type) database
- (database-underlying-type database)))
- *sql-stream*)
- (let ((constraints (database-constraint-statement
- (if (and db-type (symbolp db-type))
- (cons db-type constraints)
- constraints)
- database)))
- (when constraints
- (write-string " " *sql-stream*)
- (write-string constraints *sql-stream*)))))))
- (with-slots (name columns modifiers transactions)
- stmt
- (write-string "CREATE TABLE " *sql-stream*)
- (output-sql name database)
- (write-string " (" *sql-stream*)
- (do ((column columns (cdr column)))
- ((null (cdr column))
- (output-column (car column)))
- (output-column (car column))
- (write-string ", " *sql-stream*))
- (when modifiers
- (do ((modifier (listify modifiers) (cdr modifier)))
- ((null modifier))
- (write-string ", " *sql-stream*)
- (write-string (car modifier) *sql-stream*)))
- (write-char #\) *sql-stream*)
- (when (and (eq :mysql (database-underlying-type database))
- transactions
- (db-type-transaction-capable? :mysql database))
- (write-string " Type=InnoDB" *sql-stream*))))
- t)
-
-
-;; CREATE VIEW
-
-(defclass sql-create-view (%sql-expression)
- ((name :initarg :name :initform nil)
- (column-list :initarg :column-list :initform nil)
- (query :initarg :query :initform nil)
- (with-check-option :initarg :with-check-option :initform nil))
- (:documentation "An SQL CREATE VIEW statement."))
-
-(defmethod output-sql ((stmt sql-create-view) database)
- (with-slots (name column-list query with-check-option) stmt
- (write-string "CREATE VIEW " *sql-stream*)
- (output-sql name database)
- (when column-list (write-string " " *sql-stream*)
- (output-sql (listify column-list) database))
- (write-string " AS " *sql-stream*)
- (output-sql query database)
- (when with-check-option (write-string " WITH CHECK OPTION" *sql-stream*))))
-
-
-;;
-;; Column constraint types
-;;
-(defparameter *constraint-types*
- (list
- (cons (symbol-name-default-case "NOT-NULL") "NOT NULL")
- (cons (symbol-name-default-case "PRIMARY-KEY") "PRIMARY KEY")
- (cons (symbol-name-default-case "NOT") "NOT")
- (cons (symbol-name-default-case "NULL") "NULL")
- (cons (symbol-name-default-case "PRIMARY") "PRIMARY")
- (cons (symbol-name-default-case "KEY") "KEY")))
-
-;;
-;; Convert type spec to sql syntax
-;;
-
-(defmethod database-constraint-description (constraint database)
- (declare (ignore database))
- (let ((output (assoc (symbol-name constraint) *constraint-types*
- :test #'equal)))
- (if (null output)
- (error 'sql-user-error
- :message (format nil "unsupported column constraint '~A'"
- constraint))
- (cdr output))))
-
-(defmethod database-constraint-statement (constraint-list database)
- (declare (ignore database))
- (make-constraints-description constraint-list))
-
-(defun make-constraints-description (constraint-list)
- (if constraint-list
- (let ((string ""))
- (do ((constraint constraint-list (cdr constraint)))
- ((null constraint) string)
- (let ((output (assoc (symbol-name (car constraint))
- *constraint-types*
- :test #'equal)))
- (if (null output)
- (error 'sql-user-error
- :message (format nil "unsupported column constraint '~A'"
- constraint))
- (setq string (concatenate 'string string (cdr output))))
- (if (< 1 (length constraint))
- (setq string (concatenate 'string string " "))))))))
-
(in-package #:clsql-sys)
-(setf (documentation 'database-name 'function)
- "Returns the name of a database.")
-
-;;; Database handling
(defvar *connect-if-exists* :error
"Default value for the if-exists keyword argument in calls to
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;;
+;;;; $Id:
+;;;;
+;;;; Classes defining SQL expressions and methods for formatting the
+;;;; appropriate SQL commands.
+;;;;
+;;;; This file is part of CLSQL.
+;;;;
+;;;; CLSQL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package #:clsql-sys)
+
+(defvar +empty-string+ "''")
+
+(defvar +null-string+ "NULL")
+
+(defvar *sql-stream* nil
+ "stream which accumulates SQL output")
+
+(defun sql-output (sql-expr &optional database)
+ (progv '(*sql-stream*)
+ `(,(make-string-output-stream))
+ (output-sql sql-expr database)
+ (get-output-stream-string *sql-stream*)))
+
+
+(defclass %sql-expression ()
+ ())
+
+(defmethod output-sql ((expr %sql-expression) database)
+ (declare (ignore database))
+ (write-string +null-string+ *sql-stream*))
+
+(defmethod print-object ((self %sql-expression) stream)
+ (print-unreadable-object
+ (self stream :type t)
+ (write-string (sql-output self) stream)))
+
+;; For straight up strings
+
+(defclass sql (%sql-expression)
+ ((text
+ :initarg :string
+ :initform ""))
+ (:documentation "A literal SQL expression."))
+
+(defmethod make-load-form ((sql sql) &optional environment)
+ (declare (ignore environment))
+ (with-slots (text)
+ sql
+ `(make-instance 'sql :string ',text)))
+
+(defmethod output-sql ((expr sql) database)
+ (declare (ignore database))
+ (write-string (slot-value expr 'text) *sql-stream*)
+ t)
+
+(defmethod print-object ((ident sql) stream)
+ (format stream "#<~S \"~A\">"
+ (type-of ident)
+ (sql-output ident nil)))
+
+;; For SQL Identifiers of generic type
+(defclass sql-ident (%sql-expression)
+ ((name
+ :initarg :name
+ :initform "NULL"))
+ (:documentation "An SQL identifer."))
+
+(defmethod make-load-form ((sql sql-ident) &optional environment)
+ (declare (ignore environment))
+ (with-slots (name)
+ sql
+ `(make-instance 'sql-ident :name ',name)))
+
+(defvar *output-hash* (make-hash-table :test #'equal))
+
+(defmethod output-sql-hash-key (expr database)
+ (declare (ignore expr database))
+ nil)
+
+#+ignore
+(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)))))
+
+(defmethod output-sql ((expr sql-ident) database)
+ (with-slots (name) expr
+ (write-string
+ (convert-to-db-default-case
+ (etypecase name
+ (string name)
+ (symbol (symbol-name name)))
+ database)
+ *sql-stream*))
+ t)
+
+;; For SQL Identifiers for attributes
+
+(defclass sql-ident-attribute (sql-ident)
+ ((qualifier
+ :initarg :qualifier
+ :initform "NULL")
+ (type
+ :initarg :type
+ :initform "NULL"))
+ (:documentation "An SQL Attribute identifier."))
+
+(defmethod collect-table-refs (sql)
+ (declare (ignore sql))
+ nil)
+
+(defmethod collect-table-refs ((sql sql-ident-attribute))
+ (let ((qual (slot-value sql 'qualifier)))
+ (if (and qual (symbolp (slot-value sql 'qualifier)))
+ (list (make-instance 'sql-ident-table :name
+ (slot-value sql 'qualifier))))))
+
+(defmethod make-load-form ((sql sql-ident-attribute) &optional environment)
+ (declare (ignore environment))
+ (with-slots (qualifier type name)
+ sql
+ `(make-instance 'sql-ident-attribute :name ',name
+ :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
+ ;; Honor care of name
+ (string
+ (write-string name *sql-stream*))
+ (symbol
+ (write-string (sql-escape (convert-to-db-default-case
+ (symbol-name name) database)) *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
+ (convert-to-db-default-case (sql-escape qualifier) database))
+ (sql-escape (convert-to-db-default-case name database))
+ (when type
+ (convert-to-db-default-case (symbol-name type) database)))
+ (format *sql-stream* "~@[~A.~]~A"
+ (when qualifier
+ (typecase qualifier
+ (string (format nil "~s" qualifier))
+ (t (convert-to-db-default-case (sql-escape qualifier)
+ database))))
+ (sql-escape (convert-to-db-default-case name database))))
+ t))
+
+(defmethod output-sql-hash-key ((expr sql-ident-attribute) database)
+ (declare (ignore database))
+ (with-slots (qualifier name type)
+ expr
+ (list 'sql-ident-attribute qualifier name type)))
+
+;; For SQL Identifiers for tables
+(defclass sql-ident-table (sql-ident)
+ ((alias
+ :initarg :table-alias :initform nil))
+ (:documentation "An SQL table identifier."))
+
+(defmethod make-load-form ((sql sql-ident-table) &optional environment)
+ (declare (ignore environment))
+ (with-slots (alias name)
+ sql
+ `(make-instance 'sql-ident-table :name ',name :table-alias ',alias)))
+
+(defun generate-sql (expr database)
+ (let ((*sql-stream* (make-string-output-stream)))
+ (output-sql expr database)
+ (get-output-stream-string *sql-stream*)))
+
+(defmethod output-sql ((expr sql-ident-table) database)
+ (with-slots (name alias)
+ expr
+ (if (null alias)
+ (write-string (sql-escape (convert-to-db-default-case (symbol-name name) database)) *sql-stream*)
+ (progn
+ (write-string (sql-escape (convert-to-db-default-case (symbol-name name) database)) *sql-stream*)
+ (write-char #\Space *sql-stream*)
+ (format *sql-stream* "~s" alias))))
+ t)
+
+#|
+(defmethod database-output-sql ((self duration) database)
+ (declare (ignore database))
+ (format nil "'~a'" (duration-timestring self)))
+
+(defmethod database-output-sql ((self money) database)
+ (database-output-sql (slot-value self 'odcl::units) database))
+|#
+
+
+(defmethod output-sql-hash-key ((expr sql-ident-table) database)
+ (declare (ignore database))
+ (with-slots (name alias)
+ expr
+ (list 'sql-ident-table name alias)))
+
+(defclass sql-relational-exp (%sql-expression)
+ ((operator
+ :initarg :operator
+ :initform nil)
+ (sub-expressions
+ :initarg :sub-expressions
+ :initform nil))
+ (:documentation "An SQL relational expression."))
+
+(defmethod collect-table-refs ((sql sql-relational-exp))
+ (let ((tabs nil))
+ (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))))))
+
+
+
+
+;; Write SQL for relational operators (like 'AND' and 'OR').
+;; should do arity checking of subexpressions
+
+(defmethod output-sql ((expr sql-relational-exp) database)
+ (with-slots (operator sub-expressions)
+ expr
+ (let ((subs (if (consp (car sub-expressions))
+ (car sub-expressions)
+ sub-expressions)))
+ (write-char #\( *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-char #\Space *sql-stream*))
+ (write-char #\) *sql-stream*)))
+ t)
+
+(defclass sql-upcase-like (sql-relational-exp)
+ ()
+ (:documentation "An SQL 'like' that upcases its arguments."))
+
+;; Write SQL for relational operators (like 'AND' and 'OR').
+;; should do arity checking of subexpressions
+
+(defmethod output-sql ((expr sql-upcase-like) database)
+ (flet ((write-term (term)
+ (write-string "upper(" *sql-stream*)
+ (output-sql term database)
+ (write-char #\) *sql-stream*)))
+ (with-slots (sub-expressions)
+ expr
+ (let ((subs (if (consp (car sub-expressions))
+ (car sub-expressions)
+ sub-expressions)))
+ (write-char #\( *sql-stream*)
+ (do ((sub subs (cdr sub)))
+ ((null (cdr sub)) (write-term (car sub)))
+ (write-term (car sub))
+ (write-string " LIKE " *sql-stream*))
+ (write-char #\) *sql-stream*))))
+ t)
+
+(defclass sql-assignment-exp (sql-relational-exp)
+ ()
+ (:documentation "An SQL Assignment expression."))
+
+
+(defmethod output-sql ((expr sql-assignment-exp) database)
+ (with-slots (operator sub-expressions)
+ expr
+ (do ((sub sub-expressions (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-char #\Space *sql-stream*)))
+ t)
+
+(defclass sql-value-exp (%sql-expression)
+ ((modifier
+ :initarg :modifier
+ :initform nil)
+ (components
+ :initarg :components
+ :initform nil))
+ (:documentation
+ "An SQL value expression.")
+ )
+
+(defmethod collect-table-refs ((sql sql-value-exp))
+ (let ((tabs nil))
+ (if (listp (slot-value sql 'components))
+ (progn
+ (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)))))
+ nil)))
+
+
+
+(defmethod output-sql ((expr sql-value-exp) database)
+ (with-slots (modifier components)
+ expr
+ (if modifier
+ (progn
+ (write-char #\( *sql-stream*)
+ (output-sql modifier database)
+ (write-char #\Space *sql-stream*)
+ (output-sql components database)
+ (write-char #\) *sql-stream*))
+ (output-sql components database))))
+
+(defclass sql-typecast-exp (sql-value-exp)
+ ()
+ (:documentation "An SQL typecast expression."))
+
+(defmethod output-sql ((expr sql-typecast-exp) database)
+ (database-output-sql expr database))
+
+(defmethod database-output-sql ((expr sql-typecast-exp) database)
+ (with-slots (components)
+ expr
+ (output-sql components database)))
+
+
+(defmethod collect-table-refs ((sql sql-typecast-exp))
+ (when (slot-value sql 'components)
+ (collect-table-refs (slot-value sql 'components))))
+
+(defclass sql-function-exp (%sql-expression)
+ ((name
+ :initarg :name
+ :initform nil)
+ (args
+ :initarg :args
+ :initform nil))
+ (:documentation
+ "An SQL function expression."))
+
+(defmethod collect-table-refs ((sql sql-function-exp))
+ (let ((tabs nil))
+ (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))))))
+
+(defmethod output-sql ((expr sql-function-exp) database)
+ (with-slots (name args)
+ expr
+ (output-sql name database)
+ (when args (output-sql args database)))
+ t)
+
+
+(defclass sql-between-exp (sql-function-exp)
+ ()
+ (:documentation "An SQL between expression."))
+
+(defmethod output-sql ((expr sql-between-exp) database)
+ (with-slots (name args)
+ expr
+ (output-sql (first args) database)
+ (write-string " BETWEEN " *sql-stream*)
+ (output-sql (second args) database)
+ (write-string " AND " *sql-stream*)
+ (output-sql (third args) database))
+ t)
+
+(defclass sql-query-modifier-exp (%sql-expression)
+ ((modifier :initarg :modifier :initform nil)
+ (components :initarg :components :initform nil))
+ (:documentation "An SQL query modifier expression."))
+
+(defmethod output-sql ((expr sql-query-modifier-exp) database)
+ (with-slots (modifier components)
+ expr
+ (output-sql modifier database)
+ (write-string " " *sql-stream*)
+ (output-sql (car components) database)
+ (when components
+ (mapc #'(lambda (comp)
+ (write-string ", " *sql-stream*)
+ (output-sql comp database))
+ (cdr components))))
+ t)
+
+(defclass sql-set-exp (%sql-expression)
+ ((operator
+ :initarg :operator
+ :initform nil)
+ (sub-expressions
+ :initarg :sub-expressions
+ :initform nil))
+ (:documentation "An SQL set expression."))
+
+(defmethod collect-table-refs ((sql sql-set-exp))
+ (let ((tabs nil))
+ (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))))))
+
+(defmethod output-sql ((expr sql-set-exp) database)
+ (with-slots (operator sub-expressions)
+ expr
+ (let ((subs (if (consp (car sub-expressions))
+ (car sub-expressions)
+ sub-expressions)))
+ (when (= (length subs) 1)
+ (output-sql 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-char #\Space *sql-stream*))))
+ t)
+
+(defclass sql-query (%sql-expression)
+ ((selections
+ :initarg :selections
+ :initform nil)
+ (all
+ :initarg :all
+ :initform nil)
+ (flatp
+ :initarg :flatp
+ :initform nil)
+ (set-operation
+ :initarg :set-operation
+ :initform nil)
+ (distinct
+ :initarg :distinct
+ :initform nil)
+ (from
+ :initarg :from
+ :initform nil)
+ (where
+ :initarg :where
+ :initform nil)
+ (group-by
+ :initarg :group-by
+ :initform nil)
+ (having
+ :initarg :having
+ :initform nil)
+ (limit
+ :initarg :limit
+ :initform nil)
+ (offset
+ :initarg :offset
+ :initform nil)
+ (order-by
+ :initarg :order-by
+ :initform nil)
+ (inner-join
+ :initarg :inner-join
+ :initform nil)
+ (on
+ :initarg :on
+ :initform nil))
+ (:documentation "An SQL SELECT query."))
+
+(defclass sql-object-query (%sql-expression)
+ ((objects
+ :initarg :objects
+ :initform nil)
+ (flatp
+ :initarg :flatp
+ :initform nil)
+ (exp
+ :initarg :exp
+ :initform nil)
+ (refresh
+ :initarg :refresh
+ :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)))))
+
+(defvar *select-arguments*
+ '(:all :database :distinct :flatp :from :group-by :having :order-by
+ :set-operation :where :offset :limit :inner-join :on
+ ;; below keywords are not a SQL argument, but these keywords may terminate select
+ :caching :refresh))
+
+(defun query-arg-p (sym)
+ (member sym *select-arguments*))
+
+(defun query-get-selections (select-args)
+ "Return two values: the list of select-args up to the first keyword,
+uninclusive, and the args from that keyword to the end."
+ (let ((first-key-arg (position-if #'query-arg-p select-args)))
+ (if first-key-arg
+ (values (subseq select-args 0 first-key-arg)
+ (subseq select-args first-key-arg))
+ select-args)))
+
+(defun make-query (&rest args)
+ (flet ((select-objects (target-args)
+ (and target-args
+ (every #'(lambda (arg)
+ (and (symbolp arg)
+ (find-class arg nil)))
+ target-args))))
+ (multiple-value-bind (selections arglist)
+ (query-get-selections args)
+ (if (select-objects selections)
+ (destructuring-bind (&key flatp refresh &allow-other-keys) arglist
+ (make-instance 'sql-object-query :objects selections
+ :flatp flatp :refresh refresh
+ :exp arglist))
+ (destructuring-bind (&key all flatp set-operation distinct from where
+ group-by having order-by
+ offset limit inner-join on &allow-other-keys)
+ arglist
+ (if (null selections)
+ (error "No target columns supplied to select statement."))
+ (if (null from)
+ (error "No source tables supplied to select statement."))
+ (make-instance 'sql-query :selections selections
+ :all all :flatp flatp :set-operation set-operation
+ :distinct distinct :from from :where where
+ :limit limit :offset offset
+ :group-by group-by :having having :order-by order-by
+ :inner-join inner-join :on on))))))
+
+(defvar *in-subselect* nil)
+
+(defmethod output-sql ((query sql-query) database)
+ (with-slots (distinct selections from where group-by having order-by
+ limit offset inner-join on all set-operation)
+ query
+ (when *in-subselect*
+ (write-string "(" *sql-stream*))
+ (write-string "SELECT " *sql-stream*)
+ (when all
+ (write-string "ALL " *sql-stream*))
+ (when (and distinct (not all))
+ (write-string "DISTINCT " *sql-stream*)
+ (unless (eql t distinct)
+ (write-string "ON " *sql-stream*)
+ (output-sql distinct database)
+ (write-char #\Space *sql-stream*)))
+ (output-sql (apply #'vector selections) database)
+ (when from
+ (write-string " FROM " *sql-stream*)
+ (typecase from
+ (list (output-sql (apply #'vector from) database))
+ (string (write-string from *sql-stream*))
+ (t (output-sql from database))))
+ (when inner-join
+ (write-string " INNER JOIN " *sql-stream*)
+ (output-sql inner-join database))
+ (when on
+ (write-string " ON " *sql-stream*)
+ (output-sql on database))
+ (when where
+ (write-string " WHERE " *sql-stream*)
+ (let ((*in-subselect* t))
+ (output-sql where database)))
+ (when group-by
+ (write-string " GROUP BY " *sql-stream*)
+ (output-sql group-by database))
+ (when having
+ (write-string " HAVING " *sql-stream*)
+ (output-sql having database))
+ (when order-by
+ (write-string " ORDER BY " *sql-stream*)
+ (if (listp order-by)
+ (do ((order order-by (cdr order)))
+ ((null order))
+ (let ((item (car order)))
+ (typecase item
+ (cons
+ (output-sql (car item) database)
+ (format *sql-stream* " ~A" (cadr item)))
+ (t
+ (output-sql item database)))
+ (when (cdr order)
+ (write-char #\, *sql-stream*))))
+ (output-sql order-by database)))
+ (when limit
+ (write-string " LIMIT " *sql-stream*)
+ (output-sql limit database))
+ (when offset
+ (write-string " OFFSET " *sql-stream*)
+ (output-sql offset database))
+ (when *in-subselect*
+ (write-string ")" *sql-stream*))
+ (when set-operation
+ (write-char #\Space *sql-stream*)
+ (output-sql set-operation database)))
+ t)
+
+(defmethod output-sql ((query sql-object-query) database)
+ (declare (ignore database))
+ (with-slots (objects)
+ query
+ (when objects
+ (format *sql-stream* "(~{~A~^ ~})" objects))))
+
+
+;; INSERT
+
+(defclass sql-insert (%sql-expression)
+ ((into
+ :initarg :into
+ :initform nil)
+ (attributes
+ :initarg :attributes
+ :initform nil)
+ (values
+ :initarg :values
+ :initform nil)
+ (query
+ :initarg :query
+ :initform nil))
+ (:documentation
+ "An SQL INSERT statement."))
+
+(defmethod output-sql ((ins sql-insert) database)
+ (with-slots (into attributes values query)
+ ins
+ (write-string "INSERT INTO " *sql-stream*)
+ (output-sql
+ (typecase into
+ (string (sql-expression :attribute into))
+ (t into))
+ database)
+ (when attributes
+ (write-char #\Space *sql-stream*)
+ (output-sql attributes database))
+ (when values
+ (write-string " VALUES " *sql-stream*)
+ (output-sql values database))
+ (when query
+ (write-char #\Space *sql-stream*)
+ (output-sql query database)))
+ t)
+
+;; DELETE
+
+(defclass sql-delete (%sql-expression)
+ ((from
+ :initarg :from
+ :initform nil)
+ (where
+ :initarg :where
+ :initform nil))
+ (:documentation
+ "An SQL DELETE statement."))
+
+(defmethod output-sql ((stmt sql-delete) database)
+ (with-slots (from where)
+ stmt
+ (write-string "DELETE FROM " *sql-stream*)
+ (typecase from
+ (symbol (write-string (sql-escape from) *sql-stream*))
+ (t (output-sql from database)))
+ (when where
+ (write-string " WHERE " *sql-stream*)
+ (output-sql where database)))
+ t)
+
+;; UPDATE
+
+(defclass sql-update (%sql-expression)
+ ((table
+ :initarg :table
+ :initform nil)
+ (attributes
+ :initarg :attributes
+ :initform nil)
+ (values
+ :initarg :values
+ :initform nil)
+ (where
+ :initarg :where
+ :initform nil))
+ (:documentation "An SQL UPDATE statement."))
+
+(defmethod output-sql ((expr sql-update) database)
+ (with-slots (table where attributes values)
+ expr
+ (flet ((update-assignments ()
+ (mapcar #'(lambda (a b)
+ (make-instance 'sql-assignment-exp
+ :operator '=
+ :sub-expressions (list a b)))
+ attributes values)))
+ (write-string "UPDATE " *sql-stream*)
+ (output-sql table database)
+ (write-string " SET " *sql-stream*)
+ (output-sql (apply #'vector (update-assignments)) database)
+ (when where
+ (write-string " WHERE " *sql-stream*)
+ (output-sql where database))))
+ t)
+
+;; CREATE TABLE
+
+(defclass sql-create-table (%sql-expression)
+ ((name
+ :initarg :name
+ :initform nil)
+ (columns
+ :initarg :columns
+ :initform nil)
+ (modifiers
+ :initarg :modifiers
+ :initform nil)
+ (transactions
+ :initarg :transactions
+ :initform nil))
+ (:documentation
+ "An SQL CREATE TABLE statement."))
+
+;; Here's a real warhorse of a function!
+
+(declaim (inline listify))
+(defun listify (x)
+ (if (atom x)
+ (list x)
+ x))
+
+(defmethod output-sql ((stmt sql-create-table) database)
+ (flet ((output-column (column-spec)
+ (destructuring-bind (name type &optional db-type &rest constraints)
+ column-spec
+ (let ((type (listify type)))
+ (output-sql name database)
+ (write-char #\Space *sql-stream*)
+ (write-string
+ (if (stringp db-type) db-type ; override definition
+ (database-get-type-specifier (car type) (cdr type) database
+ (database-underlying-type database)))
+ *sql-stream*)
+ (let ((constraints (database-constraint-statement
+ (if (and db-type (symbolp db-type))
+ (cons db-type constraints)
+ constraints)
+ database)))
+ (when constraints
+ (write-string " " *sql-stream*)
+ (write-string constraints *sql-stream*)))))))
+ (with-slots (name columns modifiers transactions)
+ stmt
+ (write-string "CREATE TABLE " *sql-stream*)
+ (output-sql name database)
+ (write-string " (" *sql-stream*)
+ (do ((column columns (cdr column)))
+ ((null (cdr column))
+ (output-column (car column)))
+ (output-column (car column))
+ (write-string ", " *sql-stream*))
+ (when modifiers
+ (do ((modifier (listify modifiers) (cdr modifier)))
+ ((null modifier))
+ (write-string ", " *sql-stream*)
+ (write-string (car modifier) *sql-stream*)))
+ (write-char #\) *sql-stream*)
+ (when (and (eq :mysql (database-underlying-type database))
+ transactions
+ (db-type-transaction-capable? :mysql database))
+ (write-string " Type=InnoDB" *sql-stream*))))
+ t)
+
+
+;; CREATE VIEW
+
+(defclass sql-create-view (%sql-expression)
+ ((name :initarg :name :initform nil)
+ (column-list :initarg :column-list :initform nil)
+ (query :initarg :query :initform nil)
+ (with-check-option :initarg :with-check-option :initform nil))
+ (:documentation "An SQL CREATE VIEW statement."))
+
+(defmethod output-sql ((stmt sql-create-view) database)
+ (with-slots (name column-list query with-check-option) stmt
+ (write-string "CREATE VIEW " *sql-stream*)
+ (output-sql name database)
+ (when column-list (write-string " " *sql-stream*)
+ (output-sql (listify column-list) database))
+ (write-string " AS " *sql-stream*)
+ (output-sql query database)
+ (when with-check-option (write-string " WITH CHECK OPTION" *sql-stream*))))
+
+
+;;
+;; Column constraint types
+;;
+(defparameter *constraint-types*
+ (list
+ (cons (symbol-name-default-case "NOT-NULL") "NOT NULL")
+ (cons (symbol-name-default-case "PRIMARY-KEY") "PRIMARY KEY")
+ (cons (symbol-name-default-case "NOT") "NOT")
+ (cons (symbol-name-default-case "NULL") "NULL")
+ (cons (symbol-name-default-case "PRIMARY") "PRIMARY")
+ (cons (symbol-name-default-case "KEY") "KEY")))
+
+;;
+;; Convert type spec to sql syntax
+;;
+
+(defmethod database-constraint-description (constraint database)
+ (declare (ignore database))
+ (let ((output (assoc (symbol-name constraint) *constraint-types*
+ :test #'equal)))
+ (if (null output)
+ (error 'sql-user-error
+ :message (format nil "unsupported column constraint '~A'"
+ constraint))
+ (cdr output))))
+
+(defmethod database-constraint-statement (constraint-list database)
+ (declare (ignore database))
+ (make-constraints-description constraint-list))
+
+(defun make-constraints-description (constraint-list)
+ (if constraint-list
+ (let ((string ""))
+ (do ((constraint constraint-list (cdr constraint)))
+ ((null constraint) string)
+ (let ((output (assoc (symbol-name (car constraint))
+ *constraint-types*
+ :test #'equal)))
+ (if (null output)
+ (error 'sql-user-error
+ :message (format nil "unsupported column constraint '~A'"
+ constraint))
+ (setq string (concatenate 'string string (cdr output))))
+ (if (< 1 (length constraint))
+ (setq string (concatenate 'string string " "))))))))
+
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;;
+;;;; $Id:
+;;;;
+;;;; The CLSQL Functional Data Definition Language (FDDL)
+;;;; including functions for schema manipulation. Currently supported
+;;;; SQL objects include tables, views, indexes, attributes and
+;;;; sequences.
+;;;;
+;;;; This file is part of CLSQL.
+;;;;
+;;;; CLSQL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package #:clsql-sys)
+
+
+;; Utilities
+
+(defun database-identifier (name database)
+ (sql-escape (etypecase name
+ ;; honor case of strings
+ (string name
+ #+nil (convert-to-db-default-case name database))
+ (sql-ident (sql-output name database))
+ (symbol (sql-output name database)))))
+
+
+;; Tables
+
+(defun create-table (name description &key (database *default-database*)
+ (constraints nil) (transactions t))
+ "Creates a table called NAME, which may be a string, symbol or
+SQL table identifier, in DATABASE which defaults to
+*DEFAULT-DATABASE*. DESCRIPTION is a list whose elements are
+lists containing the attribute names, types, and other
+constraints such as not-null or primary-key for each column in
+the table. CONSTRAINTS is a string representing an SQL table
+constraint expression or a list of such strings. With MySQL
+databases, if TRANSACTIONS is t an InnoDB table is created which
+supports transactions."
+ (let* ((table-name (etypecase name
+ (symbol (sql-expression :attribute name))
+ (string (sql-expression :attribute name))
+ (sql-ident name)))
+ (stmt (make-instance 'sql-create-table
+ :name table-name
+ :columns description
+ :modifiers constraints
+ :transactions transactions)))
+ (execute-command stmt :database database)))
+
+(defun drop-table (name &key (if-does-not-exist :error)
+ (database *default-database*))
+ "Drops the table called NAME from DATABASE which defaults to
+*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)
+ (return-from drop-table nil)))
+ (:error
+ t))
+
+ ;; Fixme: move to clsql-oracle
+ (let ((expr (concatenate 'string "DROP TABLE " table-name)))
+ (when (and (find-package 'clsql-oracle)
+ (eq :oracle (database-type database))
+ (eql 10 (slot-value database
+ (intern (symbol-name '#:major-server-version)
+ (symbol-name '#:clsql-oracle)))))
+ (setq expr (concatenate 'string expr " PURGE")))
+
+ (execute-command expr :database database))))
+
+(defun list-tables (&key (owner nil) (database *default-database*))
+ "Returns a list of strings representing table names in DATABASE
+which defaults to *DEFAULT-DATABASE*. OWNER is nil by default
+which means that only tables owned by users are listed. If OWNER
+is a string denoting a user name, only tables owned by OWNER are
+listed. If OWNER is :all then all tables are listed."
+ (database-list-tables database :owner owner))
+
+(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
+which means that only tables owned by users are examined. If
+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))
+
+
+;; Views
+
+(defun create-view (name &key as column-list (with-check-option nil)
+ (database *default-database*))
+ "Creates a view called NAME in DATABASE which defaults to
+*DEFAULT-DATABASE*. The view is created using the query AS and
+the columns of the view may be specified using the COLUMN-LIST
+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)))
+ (stmt (make-instance 'sql-create-view
+ :name view-name
+ :column-list column-list
+ :query as
+ :with-check-option with-check-option)))
+ (execute-command stmt :database database)))
+
+(defun drop-view (name &key (if-does-not-exist :error)
+ (database *default-database*))
+ "Drops the view called NAME from DATABASE which defaults to
+*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)
+ (return-from drop-view)))
+ (:error
+ t))
+ (let ((expr (concatenate 'string "DROP VIEW " view-name)))
+ (execute-command expr :database database))))
+
+(defun list-views (&key (owner nil) (database *default-database*))
+ "Returns a list of strings representing view names in DATABASE
+which defaults to *DEFAULT-DATABASE*. OWNER is nil by default
+which means that only views owned by users are listed. If OWNER
+is a string denoting a user name, only views owned by OWNER are
+listed. If OWNER is :all then all views are listed."
+ (database-list-views database :owner owner))
+
+(defun view-exists-p (name &key (owner nil) (database *default-database*))
+ "Tests for the existence of an SQL view called NAME in DATABASE
+which defaults to *DEFAULT-DATABASE*. OWNER is nil by default
+which means that only views owned by users are examined. If OWNER
+is a string denoting a user name, only views owned by OWNER are
+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)
+ t))
+
+
+;; Indexes
+
+(defun create-index (name &key on (unique nil) attributes
+ (database *default-database*))
+ "Creates an index called NAME on the table specified by ON in
+DATABASE which default to *DEFAULT-DATABASE*. The table
+attributes to use in constructing the index NAME are specified by
+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)))
+ (stmt (format nil "CREATE ~A INDEX ~A ON ~A (~{~A~^, ~})"
+ (if unique "UNIQUE" "")
+ index-name table-name attributes)))
+ (execute-command stmt :database database)))
+
+(defun drop-index (name &key (if-does-not-exist :error)
+ (on nil)
+ (database *default-database*))
+ "Drops the index called NAME in DATABASE which defaults to
+*DEFAULT-DATABASE*. If the index does not exist and
+IF-DOES-NOT-EXIST is :ignore then DROP-INDEX returns nil whereas
+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))
+ (unless (db-type-use-column-on-drop-index?
+ (database-underlying-type database))
+ (setq on nil))
+ (execute-command (format nil "DROP INDEX ~A~A" index-name
+ (if (null on) ""
+ (concatenate 'string " ON "
+ (database-identifier on database))))
+ :database database)))
+
+(defun list-indexes (&key (owner nil) (database *default-database*))
+ "Returns a list of strings representing index names in DATABASE
+which defaults to *DEFAULT-DATABASE*. OWNER is nil by default
+which means that only indexes owned by users are listed. If OWNER
+is a string denoting a user name, only indexes owned by OWNER are
+listed. If OWNER is :all then all indexes are listed."
+ (database-list-indexes database :owner owner))
+
+(defun list-table-indexes (table &key (owner nil)
+ (database *default-database*))
+ "Returns a list of strings representing index names on the
+table specified by TABLE in DATABASE which defaults to
+*DEFAULT-DATABASE*. OWNER is nil by default which means that only
+indexes owned by users are listed. If OWNER is a string denoting
+a user name, only indexes owned by OWNER are listed. If OWNER
+is :all then all indexes are listed."
+ (database-list-table-indexes (database-identifier table database)
+ database :owner owner))
+
+(defun index-exists-p (name &key (owner nil) (database *default-database*))
+ "Tests for the existence of an SQL index called NAME in DATABASE
+which defaults to *DEFAULT-DATABASE*. OWNER is nil by default
+which means that only indexes owned by users are examined. If
+OWNER is a string denoting a user name, only indexes owned by
+OWNER are examined. If OWNER is :all then all indexes are
+examined."
+ (when (member (database-identifier name database)
+ (list-indexes :owner owner :database database)
+ :test #'string-equal)
+ t))
+
+;; Attributes
+
+(defvar *cache-table-queries-default* nil
+ "Specifies the default behaivour for caching of attribute
+ types. Meaningful values are t, nil and :flush as described for
+ the action argument to CACHE-TABLE-QUERIES.")
+
+(defun cache-table-queries (table &key (action nil) (database *default-database*))
+ "Controls the caching of attribute type information on the
+table specified by TABLE in DATABASE which defaults to
+*DEFAULT-DATABASE*. ACTION specifies the caching behaviour to
+adopt. If its value is t then attribute type information is
+cached whereas if its value is nil then attribute type
+information is not cached. If ACTION is :flush then all existing
+type information in the cache for TABLE is removed, but caching
+is still enabled. TABLE may be a string representing a table for
+which the caching action is to be taken while the caching action
+is applied to all tables if TABLE is t. Alternativly, when TABLE
+is :default, the default caching action specified by
+*CACHE-TABLE-QUERIES-DEFAULT* is applied to all table for which a
+caching action has not been explicitly set."
+ (with-slots (attribute-cache) database
+ (cond
+ ((stringp table)
+ (multiple-value-bind (val found) (gethash table attribute-cache)
+ (cond
+ ((and found (eq action :flush))
+ (setf (gethash table attribute-cache) (list t nil)))
+ ((and found (eq action t))
+ (setf (gethash table attribute-cache) (list t (second val))))
+ ((and found (null action))
+ (setf (gethash table attribute-cache) (list nil nil)))
+ ((not found)
+ (setf (gethash table attribute-cache) (list action nil))))))
+ ((eq table t)
+ (maphash (lambda (k v)
+ (cond
+ ((eq action :flush)
+ (setf (gethash k attribute-cache) (list t nil)))
+ ((null action)
+ (setf (gethash k attribute-cache) (list nil nil)))
+ ((eq t action)
+ (setf (gethash k attribute-cache) (list t (second v))))))
+ attribute-cache))
+ ((eq table :default)
+ (maphash (lambda (k v)
+ (when (eq (first v) :unspecified)
+ (cond
+ ((eq action :flush)
+ (setf (gethash k attribute-cache) (list t nil)))
+ ((null action)
+ (setf (gethash k attribute-cache) (list nil nil)))
+ ((eq t action)
+ (setf (gethash k attribute-cache) (list t (second v)))))))
+ attribute-cache))))
+ (values))
+
+
+(defun list-attributes (name &key (owner nil) (database *default-database*))
+ "Returns a list of strings representing the attributes of table
+NAME in DATABASE which defaults to *DEFAULT-DATABASE*. OWNER is
+nil by default which means that only attributes owned by users
+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
+ :owner owner))
+
+(defun attribute-type (attribute table &key (owner nil)
+ (database *default-database*))
+ "Returns a string representing the field type of the supplied
+attribute ATTRIBUTE in the table specified by TABLE in DATABASE
+which defaults to *DEFAULT-DATABASE*. OWNER is nil by default
+which means that the attribute specified by ATTRIBUTE, if it
+exists, must be user owned else nil is returned. If OWNER is a
+string denoting a user name, the 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
+ :owner owner))
+
+(defun list-attribute-types (table &key (owner nil)
+ (database *default-database*))
+ "Returns a list containing information about the SQL types of
+each of the attributes in the table specified by TABLE in
+DATABASE which has a default value of *DEFAULT-DATABASE*. OWNER
+is nil by default which means that only attributes owned by users
+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. The elements of the returned list are
+lists where the first element is the name of the attribute, the
+second element is its SQL type, the third is the type precision,
+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)))
+ (multiple-value-bind (val found) (gethash table-ident attribute-cache)
+ (if (and found (second val))
+ (second val)
+ (let ((types (mapcar #'(lambda (attribute)
+ (cons attribute
+ (multiple-value-list
+ (database-attribute-type
+ (database-identifier attribute
+ database)
+ table-ident
+ database
+ :owner owner))))
+ (list-attributes table :database database
+ :owner owner))))
+ (cond
+ ((and (not found) (eq t *cache-table-queries-default*))
+ (setf (gethash table-ident attribute-cache)
+ (list :unspecified types)))
+ ((and found (eq t (first val))
+ (setf (gethash table-ident attribute-cache)
+ (list t types)))))
+ types))))))
+
+
+;; Sequences
+
+(defun create-sequence (name &key (database *default-database*))
+ "Creates a sequence called NAME in DATABASE which defaults to
+*DEFAULT-DATABASE*."
+ (let ((sequence-name (database-identifier name database)))
+ (database-create-sequence sequence-name database))
+ (values))
+
+(defun drop-sequence (name &key (if-does-not-exist :error)
+ (database *default-database*))
+ "Drops the sequence called NAME from DATABASE which defaults to
+*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))
+ (values))
+
+(defun list-sequences (&key (owner nil) (database *default-database*))
+ "Returns a list of strings representing sequence names in
+DATABASE which defaults to *DEFAULT-DATABASE*. OWNER is nil by
+default which means that only sequences owned by users are
+listed. If OWNER is a string denoting a user name, only sequences
+owned by OWNER are listed. If OWNER is :all then all sequences
+are listed."
+ (database-list-sequences database :owner owner))
+
+(defun sequence-exists-p (name &key (owner nil)
+ (database *default-database*))
+ "Tests for the existence of an SQL sequence called NAME in
+DATABASE which defaults to *DEFAULT-DATABASE*. OWNER is nil by
+default which means that only sequences owned by users are
+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))
+
+(defun sequence-next (name &key (database *default-database*))
+ "Return the next value in the sequence called NAME in DATABASE
+ which defaults to *DEFAULT-DATABASE*."
+ (database-sequence-next (database-identifier name database) database))
+
+(defun set-sequence-position (name position &key (database *default-database*))
+ "Explicitly set the the position of the sequence called NAME in
+DATABASE, which defaults to *DEFAULT-DATABSE*, to POSITION."
+ (database-set-sequence-position (database-identifier name database)
+ position database))
+
+(defun sequence-last (name &key (database *default-database*))
+ "Return the last value of the sequence called NAME in DATABASE
+ which defaults to *DEFAULT-DATABASE*."
+ (database-sequence-last (database-identifier name database) database))
+
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;;
+;;;; $Id:
+;;;;
+;;;; The CLSQL Functional Data Manipulation Language (FDML).
+;;;;
+;;;; This file is part of CLSQL.
+;;;;
+;;;; CLSQL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package #:clsql-sys)
+
+;;; Basic operations on databases
+
+(defmethod database-query-result-set ((expr %sql-expression) database
+ &key full-set result-types)
+ (database-query-result-set (sql-output expr database) database
+ :full-set full-set :result-types result-types))
+
+(defmethod execute-command ((sql-expression string)
+ &key (database *default-database*))
+ (record-sql-command sql-expression database)
+ (let ((res (database-execute-command sql-expression database)))
+ (record-sql-result res database))
+ (values))
+
+(defmethod execute-command ((expr %sql-expression)
+ &key (database *default-database*))
+ (execute-command (sql-output expr database) :database database)
+ (values))
+
+(defmethod query ((query-expression string) &key (database *default-database*)
+ (result-types :auto) (flatp nil) (field-names t))
+ (record-sql-command query-expression database)
+ (multiple-value-bind (rows names)
+ (database-query query-expression database result-types field-names)
+ (let ((result (if (and flatp (= 1 (length (car rows))))
+ (mapcar #'car rows)
+ rows)))
+ (record-sql-result result database)
+ (if field-names
+ (values result names)
+ result))))
+
+(defmethod query ((expr %sql-expression) &key (database *default-database*)
+ (result-types :auto) (flatp nil) (field-names t))
+ (query (sql-output expr database) :database database :flatp flatp
+ :result-types result-types :field-names field-names))
+
+(defmethod query ((expr sql-object-query) &key (database *default-database*)
+ (result-types :auto) (flatp nil) (field-names t))
+ (declare (ignore result-types field-names))
+ (apply #'select (append (slot-value expr 'objects)
+ (slot-value expr 'exp)
+ (when (slot-value expr 'refresh)
+ (list :refresh (sql-output expr database)))
+ (when (or flatp (slot-value expr 'flatp) )
+ (list :flatp t))
+ (list :database database))))
+
+(defun truncate-database (&key (database *default-database*))
+ (unless (typep database 'database)
+ (signal-no-database-error database))
+ (unless (is-database-open database)
+ (database-reconnect database))
+ (when (eq :oracle (database-type database))
+ (ignore-errors (execute-command "PURGE RECYCLEBIN" :database database)))
+ (when (db-type-has-views? (database-underlying-type database))
+ (dolist (view (list-views :database database))
+ (drop-view view :database database)))
+ (dolist (table (list-tables :database database))
+ (drop-table table :database database))
+ (dolist (index (list-indexes :database database))
+ (drop-index index :database database))
+ (dolist (seq (list-sequences :database database))
+ (drop-sequence seq :database database))
+ (when (eq :oracle (database-type database))
+ (ignore-errors (execute-command "PURGE RECYCLEBIN" :database database))))
+
+(defun print-query (query-exp &key titles (formats t) (sizes t) (stream t)
+ (database *default-database*))
+ "Prints a tabular report of the results returned by the SQL
+query QUERY-EXP, which may be a symbolic SQL expression or a
+string, in DATABASE which defaults to *DEFAULT-DATABASE*. The
+report is printed onto STREAM which has a default value of t
+which means that *STANDARD-OUTPUT* is used. The TITLE argument,
+which defaults to nil, allows the specification of a list of
+strings to use as column titles in the tabular output. SIZES
+accepts a list of column sizes, one for each column selected by
+QUERY-EXP, to use in formatting the tabular report. The default
+value of t means that minimum sizes are computed. FORMATS is a
+list of format strings to be used for printing each column
+selected by QUERY-EXP. The default value of FORMATS is t meaning
+that ~A is used to format all columns or ~VA if column sizes are
+used."
+ (flet ((compute-sizes (data)
+ (mapcar #'(lambda (x)
+ (apply #'max (mapcar #'(lambda (y)
+ (if (null y) 3 (length y)))
+ x)))
+ (apply #'mapcar (cons #'list data))))
+ (format-record (record control sizes)
+ (format stream "~&~?" control
+ (if (null sizes) record
+ (mapcan #'(lambda (s f) (list s f)) sizes record)))))
+ (let* ((query-exp (etypecase query-exp
+ (string query-exp)
+ (sql-query (sql-output query-exp database))))
+ (data (query query-exp :database database :result-types nil
+ :field-names nil))
+ (sizes (if (or (null sizes) (listp sizes)) sizes
+ (compute-sizes (if titles (cons titles data) data))))
+ (formats (if (or (null formats) (not (listp formats)))
+ (make-list (length (car data)) :initial-element
+ (if (null sizes) "~A " "~VA "))
+ formats))
+ (control-string (format nil "~{~A~}" formats)))
+ (when titles (format-record titles control-string sizes))
+ (dolist (d data (values)) (format-record d control-string sizes)))))
+
+(defun insert-records (&key (into nil)
+ (attributes nil)
+ (values nil)
+ (av-pairs nil)
+ (query nil)
+ (database *default-database*))
+ "Inserts records into the table specified by INTO in DATABASE
+which defaults to *DEFAULT-DATABASE*. There are five ways of
+specifying the values inserted into each row. In the first VALUES
+contains a list of values to insert and ATTRIBUTES, AV-PAIRS and
+QUERY are nil. This can be used when values are supplied for all
+attributes in INTO. In the second, ATTRIBUTES is a list of column
+names, VALUES is a corresponding list of values and AV-PAIRS and
+QUERY are nil. In the third, ATTRIBUTES, VALUES and QUERY are nil
+and AV-PAIRS is an alist of (attribute value) pairs. In the
+fourth, VALUES, AV-PAIRS and ATTRIBUTES are nil and QUERY is a
+symbolic SQL query expression in which the selected columns also
+exist in INTO. In the fifth method, VALUES and AV-PAIRS are nil
+and ATTRIBUTES is a list of column names and QUERY is a symbolic
+SQL query expression which returns values for the specified
+columns."
+ (let ((stmt (make-sql-insert :into into :attrs attributes
+ :vals values :av-pairs av-pairs
+ :subquery query)))
+ (execute-command stmt :database database)))
+
+(defun make-sql-insert (&key (into nil)
+ (attrs nil)
+ (vals nil)
+ (av-pairs nil)
+ (subquery nil))
+ (unless into
+ (error 'sql-user-error :message ":into keyword not supplied"))
+ (let ((insert (make-instance 'sql-insert :into into)))
+ (with-slots (attributes values query)
+ insert
+ (cond ((and vals (not attrs) (not query) (not av-pairs))
+ (setf values vals))
+ ((and vals attrs (not subquery) (not av-pairs))
+ (setf attributes attrs)
+ (setf values vals))
+ ((and av-pairs (not vals) (not attrs) (not subquery))
+ (setf attributes (mapcar #'car av-pairs))
+ (setf values (mapcar #'cadr av-pairs)))
+ ((and subquery (not vals) (not attrs) (not av-pairs))
+ (setf query subquery))
+ ((and subquery attrs (not vals) (not av-pairs))
+ (setf attributes attrs)
+ (setf query subquery))
+ (t
+ (error 'sql-user-error
+ :message "bad or ambiguous keyword combination.")))
+ insert)))
+
+(defun delete-records (&key (from nil)
+ (where nil)
+ (database *default-database*))
+ "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)))
+ (execute-command stmt :database database)))
+
+(defun update-records (table &key (attributes nil)
+ (values nil)
+ (av-pairs nil)
+ (where nil)
+ (database *default-database*))
+ "Updates the attribute values of existing records satsifying
+the SQL expression WHERE in the table specified by TABLE in
+DATABASE which defaults to *DEFAULT-DATABASE*. There are three
+ways of specifying the values to update for each row. In the
+first, VALUES contains a list of values to use in the update and
+ATTRIBUTES, AV-PAIRS and QUERY are nil. This can be used when
+values are supplied for all attributes in TABLE. In the second,
+ATTRIBUTES is a list of column names, VALUES is a corresponding
+list of values and AV-PAIRS and QUERY are nil. In the third,
+ATTRIBUTES, VALUES and QUERY are nil and AV-PAIRS is an alist
+of (attribute value) pairs."
+ (when av-pairs
+ (setf attributes (mapcar #'car av-pairs)
+ values (mapcar #'cadr av-pairs)))
+ (let ((stmt (make-instance 'sql-update :table table
+ :attributes attributes
+ :values values
+ :where where)))
+ (execute-command stmt :database database)))
+
+
+;; iteration
+
+;; output-sql
+
+(defmethod database-output-sql ((str string) database)
+ (declare (ignore database)
+ (optimize (speed 3) (safety 1) #+cmu (extensions:inhibit-warnings 3))
+ (type (simple-array * (*)) str))
+ (let ((len (length str)))
+ (declare (type fixnum len))
+ (cond ((= len 0)
+ +empty-string+)
+ ((and (null (position #\' str))
+ (null (position #\\ str)))
+ (concatenate 'string "'" str "'"))
+ (t
+ (let ((buf (make-string (+ (* len 2) 2) :initial-element #\')))
+ (do* ((i 0 (incf i))
+ (j 1 (incf j)))
+ ((= i len) (subseq buf 0 (1+ j)))
+ (declare (type integer i j))
+ (let ((char (aref str i)))
+ (cond ((eql char #\')
+ (setf (aref buf j) #\\)
+ (incf j)
+ (setf (aref buf j) #\'))
+ ((eql char #\\)
+ (setf (aref buf j) #\\)
+ (incf j)
+ (setf (aref buf j) #\\))
+ (t
+ (setf (aref buf j) char))))))))))
+
+(let ((keyword-package (symbol-package :foo)))
+ (defmethod database-output-sql ((sym symbol) database)
+ (convert-to-db-default-case
+ (if (equal (symbol-package sym) keyword-package)
+ (concatenate 'string "'" (string sym) "'")
+ (symbol-name sym))
+ database)))
+
+(defmethod database-output-sql ((tee (eql t)) database)
+ (declare (ignore database))
+ "'Y'")
+
+(defmethod database-output-sql ((num number) database)
+ (declare (ignore database))
+ (princ-to-string num))
+
+(defmethod database-output-sql ((arg list) database)
+ (if (null arg)
+ "NULL"
+ (format nil "(~{~A~^,~})" (mapcar #'(lambda (val)
+ (sql-output val database))
+ arg))))
+
+(defmethod database-output-sql ((arg vector) database)
+ (format nil "~{~A~^,~}" (map 'list #'(lambda (val)
+ (sql-output val database))
+ arg)))
+
+(defmethod database-output-sql ((self wall-time) database)
+ (declare (ignore database))
+ (db-timestring self))
+
+(defmethod database-output-sql ((self duration) database)
+ (declare (ignore database))
+ (format nil "'~a'" (duration-timestring self)))
+
+(defmethod database-output-sql (thing database)
+ (if (or (null thing)
+ (eq 'null thing))
+ "NULL"
+ (error 'sql-user-error
+ :message
+ (format nil
+ "No type conversion to SQL for ~A is defined for DB ~A."
+ (type-of thing) (type-of database)))))
+
+
+(defmethod output-sql-hash-key ((arg vector) database)
+ (list 'vector (map 'list (lambda (arg)
+ (or (output-sql-hash-key arg database)
+ (return-from output-sql-hash-key nil)))
+ arg)))
+
+(defmethod output-sql (expr database)
+ (write-string (database-output-sql expr database) *sql-stream*)
+ (values))
+
+(defmethod output-sql ((expr list) database)
+ (if (null expr)
+ (write-string +null-string+ *sql-stream*)
+ (progn
+ (write-char #\( *sql-stream*)
+ (do ((item expr (cdr item)))
+ ((null (cdr item))
+ (output-sql (car item) database))
+ (output-sql (car item) database)
+ (write-char #\, *sql-stream*))
+ (write-char #\) *sql-stream*)))
+ t)
+
+(defmethod describe-table ((table sql-create-table)
+ &key (database *default-database*))
+ (database-describe-table
+ database
+ (convert-to-db-default-case
+ (symbol-name (slot-value table 'name)) database)))
+
+#+nil
+(defmethod add-storage-class ((self database) (class symbol) &key (sequence t))
+ (let ((tablename (view-table (find-class class))))
+ (unless (tablep tablename)
+ (create-view-from-class class)
+ (when sequence
+ (create-sequence-from-class class)))))
+
+;;; Iteration
+
+
+(defmacro do-query (((&rest args) query-expression
+ &key (database '*default-database*) (result-types :auto))
+ &body body)
+ "Repeatedly executes BODY within a binding of ARGS on the
+fields of each row selected by the SQL query QUERY-EXPRESSION,
+which may be a string or a symbolic SQL expression, in DATABASE
+which defaults to *DEFAULT-DATABASE*. The values returned by the
+execution of BODY are returned. RESULT-TYPES is a list of symbols
+which specifies the lisp type for each field returned by
+QUERY-EXPRESSION. If RESULT-TYPES is nil all results are returned
+as strings whereas the default value of :auto means that the lisp
+types are automatically computed for each field."
+ (let ((result-set (gensym "RESULT-SET-"))
+ (qe (gensym "QUERY-EXPRESSION-"))
+ (columns (gensym "COLUMNS-"))
+ (row (gensym "ROW-"))
+ (db (gensym "DB-")))
+ `(let ((,qe ,query-expression))
+ (typecase ,qe
+ (sql-object-query
+ (dolist (,row (query ,qe))
+ (destructuring-bind ,args
+ ,row
+ ,@body)))
+ (t
+ ;; Functional query
+ (let ((,db ,database))
+ (multiple-value-bind (,result-set ,columns)
+ (database-query-result-set ,qe ,db
+ :full-set nil
+ :result-types ,result-types)
+ (when ,result-set
+ (unwind-protect
+ (do ((,row (make-list ,columns)))
+ ((not (database-store-next-row ,result-set ,db ,row))
+ nil)
+ (destructuring-bind ,args ,row
+ ,@body))
+ (database-dump-result-set ,result-set ,db))))))))))
+
+(defun map-query (output-type-spec function query-expression
+ &key (database *default-database*)
+ (result-types :auto))
+ "Map the function FUNCTION over the attribute values of each
+row selected by the SQL query QUERY-EXPRESSION, which may be a
+string or a symbolic SQL expression, in DATABASE which defaults
+to *DEFAULT-DATABASE*. The results of the function are collected
+as specified in OUTPUT-TYPE-SPEC and returned like in
+MAP. RESULT-TYPES is a list of symbols which specifies the lisp
+type for each field returned by QUERY-EXPRESSION. If RESULT-TYPES
+is nil all results are returned as strings whereas the default
+value of :auto means that the lisp types are automatically
+computed for each field."
+ (typecase query-expression
+ (sql-object-query
+ (map output-type-spec #'(lambda (x) (apply function x))
+ (query query-expression)))
+ (t
+ ;; Functional query
+ (macrolet ((type-specifier-atom (type)
+ `(if (atom ,type) ,type (car ,type))))
+ (case (type-specifier-atom output-type-spec)
+ ((nil)
+ (map-query-for-effect function query-expression database
+ result-types))
+ (list
+ (map-query-to-list function query-expression database result-types))
+ ((simple-vector simple-string vector string array simple-array
+ bit-vector simple-bit-vector base-string
+ simple-base-string)
+ (map-query-to-simple output-type-spec function query-expression
+ database result-types))
+ (t
+ (funcall #'map-query
+ (cmucl-compat:result-type-or-lose output-type-spec t)
+ function query-expression :database database
+ :result-types result-types)))))))
+
+(defun map-query-for-effect (function query-expression database result-types)
+ (multiple-value-bind (result-set columns)
+ (database-query-result-set query-expression database :full-set nil
+ :result-types result-types)
+ (let ((flatp (and (= columns 1)
+ (typecase query-expression
+ (string t)
+ (sql-query
+ (slot-value query-expression 'flatp))))))
+ (when result-set
+ (unwind-protect
+ (do ((row (make-list columns)))
+ ((not (database-store-next-row result-set database row))
+ nil)
+ (if flatp
+ (apply function row)
+ (funcall function row)))
+ (database-dump-result-set result-set database))))))
+
+(defun map-query-to-list (function query-expression database result-types)
+ (multiple-value-bind (result-set columns)
+ (database-query-result-set query-expression database :full-set nil
+ :result-types result-types)
+ (let ((flatp (and (= columns 1)
+ (typecase query-expression
+ (string t)
+ (sql-query
+ (slot-value query-expression 'flatp))))))
+ (when result-set
+ (unwind-protect
+ (let ((result (list nil)))
+ (do ((row (make-list columns))
+ (current-cons result (cdr current-cons)))
+ ((not (database-store-next-row result-set database row))
+ (cdr result))
+ (rplacd current-cons
+ (list (if flatp
+ (apply function row)
+ (funcall function (copy-list row)))))))
+ (database-dump-result-set result-set database))))))
+
+(defun map-query-to-simple (output-type-spec function query-expression database result-types)
+ (multiple-value-bind (result-set columns rows)
+ (database-query-result-set query-expression database :full-set t
+ :result-types result-types)
+ (let ((flatp (and (= columns 1)
+ (typecase query-expression
+ (string t)
+ (sql-query
+ (slot-value query-expression 'flatp))))))
+ (when result-set
+ (unwind-protect
+ (if rows
+ ;; We know the row count in advance, so we allocate once
+ (do ((result
+ (cmucl-compat:make-sequence-of-type output-type-spec rows))
+ (row (make-list columns))
+ (index 0 (1+ index)))
+ ((not (database-store-next-row result-set database row))
+ result)
+ (declare (fixnum index))
+ (setf (aref result index)
+ (if flatp
+ (apply function row)
+ (funcall function (copy-list row)))))
+ ;; Database can't report row count in advance, so we have
+ ;; to grow and shrink our vector dynamically
+ (do ((result
+ (cmucl-compat:make-sequence-of-type output-type-spec 100))
+ (allocated-length 100)
+ (row (make-list columns))
+ (index 0 (1+ index)))
+ ((not (database-store-next-row result-set database row))
+ (cmucl-compat:shrink-vector result index))
+ (declare (fixnum allocated-length index))
+ (when (>= index allocated-length)
+ (setq allocated-length (* allocated-length 2)
+ result (adjust-array result allocated-length)))
+ (setf (aref result index)
+ (if flatp
+ (apply function row)
+ (funcall function (copy-list row))))))
+ (database-dump-result-set result-set database))))))
+
+;;; Row processing macro from CLSQL
+
+(defmacro for-each-row (((&rest fields) &key from order-by where distinct limit) &body body)
+ (let ((d (gensym "DISTINCT-"))
+ (bind-fields (loop for f in fields collect (car f)))
+ (w (gensym "WHERE-"))
+ (o (gensym "ORDER-BY-"))
+ (frm (gensym "FROM-"))
+ (l (gensym "LIMIT-"))
+ (q (gensym "QUERY-")))
+ `(let ((,frm ,from)
+ (,w ,where)
+ (,d ,distinct)
+ (,l ,limit)
+ (,o ,order-by))
+ (let ((,q (query-string ',fields ,frm ,w ,d ,o ,l)))
+ (loop for tuple in (query ,q)
+ collect (destructuring-bind ,bind-fields tuple
+ ,@body))))))
+
+(defun query-string (fields from where distinct order-by limit)
+ (concatenate
+ 'string
+ (format nil "select ~A~{~A~^,~} from ~{~A~^ and ~}"
+ (if distinct "distinct " "") (field-names fields)
+ (from-names from))
+ (if where (format nil " where ~{~A~^ ~}"
+ (where-strings where)) "")
+ (if order-by (format nil " order by ~{~A~^, ~}"
+ (order-by-strings order-by)))
+ (if limit (format nil " limit ~D" limit) "")))
+
+(defun lisp->sql-name (field)
+ (typecase field
+ (string field)
+ (symbol (string-upcase (symbol-name field)))
+ (cons (cadr field))
+ (t (format nil "~A" field))))
+
+(defun field-names (field-forms)
+ "Return a list of field name strings from a fields form"
+ (loop for field-form in field-forms
+ collect
+ (lisp->sql-name
+ (if (cadr field-form)
+ (cadr field-form)
+ (car field-form)))))
+
+(defun from-names (from)
+ "Return a list of field name strings from a fields form"
+ (loop for table in (if (atom from) (list from) from)
+ collect (lisp->sql-name table)))
+
+
+(defun where-strings (where)
+ (loop for w in (if (atom (car where)) (list where) where)
+ collect
+ (if (consp w)
+ (format nil "~A ~A ~A" (second w) (first w) (third w))
+ (format nil "~A" w))))
+
+(defun order-by-strings (order-by)
+ (loop for o in order-by
+ collect
+ (if (atom o)
+ (lisp->sql-name o)
+ (format nil "~A ~A" (lisp->sql-name (car o))
+ (lisp->sql-name (cadr o))))))
+
+
+;;; Large objects support
+
+(defun create-large-object (&key (database *default-database*))
+ "Creates a new large object in the database and returns the object identifier"
+ (database-create-large-object database))
+
+(defun write-large-object (object-id data &key (database *default-database*))
+ "Writes data to the large object"
+ (database-write-large-object object-id data database))
+
+(defun read-large-object (object-id &key (database *default-database*))
+ "Reads the large object content"
+ (database-read-large-object object-id database))
+
+(defun delete-large-object (object-id &key (database *default-database*))
+ "Deletes the large object in the database"
+ (database-delete-large-object object-id database))
+
+
(in-package #:clsql-sys)
+
+;; FDML
+
+(defgeneric execute-command (expression &key database)
+ (:documentation
+ "Executes the SQL command EXPRESSION, which may be an SQL
+expression or a string representing any SQL statement apart from
+a query, on the supplied DATABASE which defaults to
+*DEFAULT-DATABASE*."))
+
+
+(defgeneric query (query-expression &key database result-types flatp field-names)
+ (:documentation
+ "Executes the SQL query expression QUERY-EXPRESSION, which may
+be an SQL expression or a string, on the supplied DATABASE which
+defaults to *DEFAULT-DATABASE*. RESULT-TYPES is a list of symbols
+which specifies the lisp type for each field returned by
+QUERY-EXPRESSION. If RESULT-TYPES is nil all results are returned
+as strings whereas the default value of :auto means that the lisp
+types are automatically computed for each field. FIELD-NAMES is t
+by default which means that the second value returned is a list
+of strings representing the columns selected by
+QUERY-EXPRESSION. If FIELD-NAMES is nil, the list of column names
+is not returned as a second value. FLATP has a default value of
+nil which means that the results are returned as a list of
+lists. If FLATP is t and only one result is returned for each
+record selected by QUERY-EXPRESSION, the results are returned as
+elements of a list."))
+
+
+;; OODML
+
(defgeneric update-record-from-slot (object slot &key database)
(:documentation
"Updates the value stored in the column represented by the
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;;
-;;;; $Id$
-;;;;
-;;;; The CLSQL Object Oriented Data Definitional Language (OODDL)
-;;;; and Object Oriented Data Manipulation Language (OODML).
-;;;;
-;;;; This file is part of CLSQL.
-;;;;
-;;;; CLSQL users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(in-package #:clsql-sys)
-
-(defclass standard-db-object ()
- ((view-database :initform nil :initarg :view-database :reader view-database
- :db-kind :virtual))
- (:metaclass standard-db-class)
- (:documentation "Superclass for all CLSQL View Classes."))
-
-(defvar *db-auto-sync* nil
- "A non-nil value means that creating View Class instances or
- setting their slots automatically creates/updates the
- corresponding records in the underlying database.")
-
-(defvar *db-deserializing* nil)
-(defvar *db-initializing* nil)
-
-(defmethod slot-value-using-class ((class standard-db-class) instance slot-def)
- (declare (optimize (speed 3)))
- (unless *db-deserializing*
- (let* ((slot-name (%svuc-slot-name slot-def))
- (slot-object (%svuc-slot-object slot-def class))
- (slot-kind (view-class-slot-db-kind slot-object)))
- (when (and (eql slot-kind :join)
- (not (slot-boundp instance slot-name)))
- (let ((*db-deserializing* t))
- (if (view-database instance)
- (setf (slot-value instance slot-name)
- (fault-join-slot class instance slot-object))
- (setf (slot-value instance slot-name) nil))))))
- (call-next-method))
-
-(defmethod (setf slot-value-using-class) (new-value (class standard-db-class)
- instance slot-def)
- (declare (ignore new-value))
- (let* ((slot-name (%svuc-slot-name slot-def))
- (slot-object (%svuc-slot-object slot-def class))
- (slot-kind (view-class-slot-db-kind slot-object)))
- (call-next-method)
- (when (and *db-auto-sync*
- (not *db-initializing*)
- (not *db-deserializing*)
- (not (eql slot-kind :virtual)))
- (update-record-from-slot instance slot-name))))
-
-(defmethod initialize-instance ((object standard-db-object)
- &rest all-keys &key &allow-other-keys)
- (declare (ignore all-keys))
- (let ((*db-initializing* t))
- (call-next-method)
- (when (and *db-auto-sync*
- (not *db-deserializing*))
- (update-records-from-instance object))))
-
-;;
-;; Build the database tables required to store the given view class
-;;
-
-(defun create-view-from-class (view-class-name
- &key (database *default-database*))
- "Creates a table as defined by the View Class VIEW-CLASS-NAME
-in DATABASE which defaults to *DEFAULT-DATABASE*."
- (let ((tclass (find-class view-class-name)))
- (if tclass
- (let ((*default-database* database))
- (%install-class tclass database))
- (error "Class ~s not found." view-class-name)))
- (values))
-
-(defmethod %install-class ((self standard-db-class) database &aux schemadef)
- (dolist (slotdef (ordered-class-slots self))
- (let ((res (database-generate-column-definition (class-name self)
- slotdef database)))
- (when res
- (push res schemadef))))
- (unless schemadef
- (error "Class ~s has no :base slots" self))
- (create-table (sql-expression :table (view-table self)) (nreverse schemadef)
- :database database
- :constraints (database-pkey-constraint self database))
- (push self (database-view-classes database))
- t)
-
-(defmethod database-pkey-constraint ((class standard-db-class) database)
- (let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class))))
- (when keylist
- (convert-to-db-default-case
- (format nil "CONSTRAINT ~APK PRIMARY KEY~A"
- (database-output-sql (view-table class) database)
- (database-output-sql keylist database))
- database))))
-
-(defmethod database-generate-column-definition (class slotdef database)
- (declare (ignore database class))
- (when (member (view-class-slot-db-kind slotdef) '(:base :key))
- (let ((cdef
- (list (sql-expression :attribute (view-class-slot-column slotdef))
- (specified-type slotdef))))
- (setf cdef (append cdef (list (view-class-slot-db-type slotdef))))
- (let ((const (view-class-slot-db-constraints slotdef)))
- (when const
- (setq cdef (append cdef (list const)))))
- cdef)))
-
-
-;;
-;; Drop the tables which store the given view class
-;;
-
-(defun drop-view-from-class (view-class-name &key (database *default-database*))
- "Removes a table defined by the View Class VIEW-CLASS-NAME from
-DATABASE which defaults to *DEFAULT-DATABASE*."
- (let ((tclass (find-class view-class-name)))
- (if tclass
- (let ((*default-database* database))
- (%uninstall-class tclass))
- (error "Class ~s not found." view-class-name)))
- (values))
-
-(defun %uninstall-class (self &key (database *default-database*))
- (drop-table (sql-expression :table (view-table self))
- :if-does-not-exist :ignore
- :database database)
- (setf (database-view-classes database)
- (remove self (database-view-classes database))))
-
-
-;;
-;; List all known view classes
-;;
-
-(defun list-classes (&key (test #'identity)
- (root-class (find-class 'standard-db-object))
- (database *default-database*))
- "Returns a list of all the View Classes which are connected to
-DATABASE, which defaults to *DEFAULT-DATABASE*, and which descend
-from the class ROOT-CLASS and which satisfy the function TEST. By
-default ROOT-CLASS is STANDARD-DB-OBJECT and TEST is IDENTITY."
- (flet ((find-superclass (class)
- (member root-class (class-precedence-list class))))
- (let ((view-classes (and database (database-view-classes database))))
- (when view-classes
- (remove-if #'(lambda (c) (or (not (funcall test c))
- (not (find-superclass c))))
- view-classes)))))
-
-;;
-;; Define a new view class
-;;
-
-(defmacro def-view-class (class supers slots &rest cl-options)
- "Creates a View Class called CLASS whose slots SLOTS can map
-onto the attributes of a table in a database. If SUPERS is nil
-then the superclass of CLASS will be STANDARD-DB-OBJECT,
-otherwise SUPERS is a list of superclasses for CLASS which must
-include STANDARD-DB-OBJECT or a descendent of this class. The
-syntax of DEFCLASS is extended through the addition of a class
-option :base-table which defines the database table onto which
-the View Class maps and which defaults to CLASS. The DEFCLASS
-syntax is also extended through additional slot
-options. The :db-kind slot option specifies the kind of DB
-mapping which is performed for this slot and defaults to :base
-which indicates that the slot maps to an ordinary column of the
-database table. A :db-kind value of :key indicates that this slot
-is a special kind of :base slot which maps onto a column which is
-one of the unique keys for the database table, the value :join
-indicates this slot represents a join onto another View Class
-which contains View Class objects, and the value :virtual
-indicates a standard CLOS slot which does not map onto columns of
-the database table. If a slot is specified with :db-kind :join,
-the slot option :db-info contains a list which specifies the
-nature of the join. For slots of :db-kind :base or :key,
-the :type slot option has a special interpretation such that Lisp
-types, such as string, integer and float are automatically
-converted into appropriate SQL types for the column onto which
-the slot maps. This behaviour may be over-ridden using
-the :db-type slot option which is a string specifying the
-vendor-specific database type for this slot's column definition
-in the database. The :column slot option specifies the name of
-the SQL column which the slot maps onto, if :db-kind is
-not :virtual, and defaults to the slot name. The :void-value slot
-option specifies the value to store if the SQL value is NULL and
-defaults to NIL. The :db-constraints slot option is a string
-representing an SQL table constraint expression or a list of such
-strings."
- `(progn
- (defclass ,class ,supers ,slots
- ,@(if (find :metaclass `,cl-options :key #'car)
- `,cl-options
- (cons '(:metaclass clsql-sys::standard-db-class) `,cl-options)))
- (finalize-inheritance (find-class ',class))
- (find-class ',class)))
-
-(defun keyslots-for-class (class)
- (slot-value class 'key-slots))
-
-(defun key-qualifier-for-instance (obj &key (database *default-database*))
- (let ((tb (view-table (class-of obj))))
- (flet ((qfk (k)
- (sql-operation '==
- (sql-expression :attribute
- (view-class-slot-column k)
- :table tb)
- (db-value-from-slot
- k
- (slot-value obj (slot-definition-name k))
- database))))
- (let* ((keys (keyslots-for-class (class-of obj)))
- (keyxprs (mapcar #'qfk (reverse keys))))
- (cond
- ((= (length keyxprs) 0) nil)
- ((= (length keyxprs) 1) (car keyxprs))
- ((> (length keyxprs) 1) (apply #'sql-operation 'and keyxprs)))))))
-
-;;
-;; Function used by 'generate-selection-list'
-;;
-
-(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)))
- ((eq (view-class-slot-db-kind slotdef) :key)
- (sql-expression :attribute (view-class-slot-column slotdef)
- :table (view-table vclass)))
- (t nil)))
-
-;;
-;; Function used by 'find-all'
-;;
-
-(defun generate-selection-list (vclass)
- (let ((sels nil))
- (dolist (slotdef (ordered-class-slots vclass))
- (let ((res (generate-attribute-reference vclass slotdef)))
- (when res
- (push (cons slotdef res) sels))))
- (if sels
- sels
- (error "No slots of type :base in view-class ~A" (class-name vclass)))))
-
-
-
-(defun generate-retrieval-joins-list (vclass retrieval-method)
- "Returns list of immediate join slots for a class."
- (let ((join-slotdefs nil))
- (dolist (slotdef (ordered-class-slots vclass) join-slotdefs)
- (when (and (eq :join (view-class-slot-db-kind slotdef))
- (eq retrieval-method (gethash :retrieval (view-class-slot-db-info slotdef))))
- (push slotdef join-slotdefs)))))
-
-(defun generate-immediate-joins-selection-list (vclass)
- "Returns list of immediate join slots for a class."
- (let (sels)
- (dolist (joined-slot (generate-retrieval-joins-list vclass :immediate) sels)
- (let* ((join-class-name (gethash :join-class (view-class-slot-db-info joined-slot)))
- (join-class (when join-class-name (find-class join-class-name))))
- (dolist (slotdef (ordered-class-slots join-class))
- (let ((res (generate-attribute-reference join-class slotdef)))
- (when res
- (push (cons slotdef res) sels))))))
- sels))
-
-
-;; Called by 'get-slot-values-from-view'
-;;
-
-(defvar *update-context* nil)
-
-(defmethod update-slot-from-db ((instance standard-db-object) slotdef value)
- (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
- (let* ((slot-reader (view-class-slot-db-reader slotdef))
- (slot-name (slot-definition-name slotdef))
- (slot-type (specified-type slotdef))
- (*update-context* (cons (type-of instance) slot-name)))
- (cond ((and value (null slot-reader))
- (setf (slot-value instance slot-name)
- (read-sql-value value (delistify slot-type)
- (view-database instance)
- (database-underlying-type
- (view-database instance)))))
- ((null value)
- (update-slot-with-null instance slot-name slotdef))
- ((typep slot-reader 'string)
- (setf (slot-value instance slot-name)
- (format nil slot-reader value)))
- ((typep slot-reader 'function)
- (setf (slot-value instance slot-name)
- (apply slot-reader (list value))))
- (t
- (error "Slot reader is of an unusual type.")))))
-
-(defmethod key-value-from-db (slotdef value database)
- (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
- (let ((slot-reader (view-class-slot-db-reader slotdef))
- (slot-type (specified-type slotdef)))
- (cond ((and value (null slot-reader))
- (read-sql-value value (delistify slot-type) database
- (database-underlying-type database)))
- ((null value)
- nil)
- ((typep slot-reader 'string)
- (format nil slot-reader value))
- ((typep slot-reader 'function)
- (apply slot-reader (list value)))
- (t
- (error "Slot reader is of an unusual type.")))))
-
-(defun db-value-from-slot (slotdef val database)
- (let ((dbwriter (view-class-slot-db-writer slotdef))
- (dbtype (specified-type slotdef)))
- (typecase dbwriter
- (string (format nil dbwriter val))
- (function (apply dbwriter (list val)))
- (t
- (database-output-sql-as-type
- (typecase dbtype
- (cons (car dbtype))
- (t dbtype))
- val database (database-underlying-type database))))))
-
-(defun check-slot-type (slotdef val)
- (let* ((slot-type (specified-type slotdef))
- (basetype (if (listp slot-type) (car slot-type) slot-type)))
- (when (and slot-type val)
- (unless (typep val basetype)
- (error 'sql-user-error
- :message
- (format nil "Invalid value ~A in slot ~A, not of type ~A."
- val (slot-definition-name slotdef) slot-type))))))
-
-;;
-;; Called by find-all
-;;
-
-(defmethod get-slot-values-from-view (obj slotdeflist values)
- (flet ((update-slot (slot-def values)
- (update-slot-from-db obj slot-def values)))
- (mapc #'update-slot slotdeflist values)
- obj))
-
-(defmethod update-record-from-slot ((obj standard-db-object) slot &key
- (database *default-database*))
- (let* ((database (or (view-database obj) database))
- (vct (view-table (class-of obj)))
- (sd (slotdef-for-slot-with-class slot (class-of obj))))
- (check-slot-type sd (slot-value obj slot))
- (let* ((att (view-class-slot-column sd))
- (val (db-value-from-slot sd (slot-value obj slot) database)))
- (cond ((and vct sd (view-database obj))
- (update-records (sql-expression :table vct)
- :attributes (list (sql-expression :attribute att))
- :values (list val)
- :where (key-qualifier-for-instance
- obj :database database)
- :database database))
- ((and vct sd (not (view-database obj)))
- (insert-records :into (sql-expression :table vct)
- :attributes (list (sql-expression :attribute att))
- :values (list val)
- :database database)
- (setf (slot-value obj 'view-database) database))
- (t
- (error "Unable to update record.")))))
- (values))
-
-(defmethod update-record-from-slots ((obj standard-db-object) slots &key
- (database *default-database*))
- (let* ((database (or (view-database obj) database))
- (vct (view-table (class-of obj)))
- (sds (slotdefs-for-slots-with-class slots (class-of obj)))
- (avps (mapcar #'(lambda (s)
- (let ((val (slot-value
- obj (slot-definition-name s))))
- (check-slot-type s val)
- (list (sql-expression
- :attribute (view-class-slot-column s))
- (db-value-from-slot s val database))))
- sds)))
- (cond ((and avps (view-database obj))
- (update-records (sql-expression :table vct)
- :av-pairs avps
- :where (key-qualifier-for-instance
- obj :database database)
- :database database))
- ((and avps (not (view-database obj)))
- (insert-records :into (sql-expression :table vct)
- :av-pairs avps
- :database database)
- (setf (slot-value obj 'view-database) database))
- (t
- (error "Unable to update records"))))
- (values))
-
-(defmethod update-records-from-instance ((obj standard-db-object)
- &key (database *default-database*))
- (let ((database (or (view-database obj) database)))
- (labels ((slot-storedp (slot)
- (and (member (view-class-slot-db-kind slot) '(:base :key))
- (slot-boundp obj (slot-definition-name slot))))
- (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))
- (db-value-from-slot slot value database)))))
- (let* ((view-class (class-of obj))
- (view-class-table (view-table view-class))
- (slots (remove-if-not #'slot-storedp
- (ordered-class-slots view-class)))
- (record-values (mapcar #'slot-value-list slots)))
- (unless record-values
- (error "No settable slots."))
- (if (view-database obj)
- (update-records (sql-expression :table view-class-table)
- :av-pairs record-values
- :where (key-qualifier-for-instance
- obj :database database)
- :database database)
- (progn
- (insert-records :into (sql-expression :table view-class-table)
- :av-pairs record-values
- :database database)
- (setf (slot-value obj 'view-database) database))))))
- (values))
-
-(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 (slot-value instance 'view-database) nil))
- (signal-no-database-error vd))))
-
-(defmethod update-instance-from-records ((instance standard-db-object)
- &key (database *default-database*))
- (let* ((view-class (find-class (class-name (class-of instance))))
- (view-table (sql-expression :table (view-table view-class)))
- (vd (or (view-database instance) database))
- (view-qual (key-qualifier-for-instance instance :database vd))
- (sels (generate-selection-list view-class))
- (res (apply #'select (append (mapcar #'cdr sels)
- (list :from view-table
- :where view-qual)
- (list :result-types nil)))))
- (when res
- (get-slot-values-from-view instance (mapcar #'car sels) (car res)))))
-
-(defmethod update-slot-from-record ((instance standard-db-object)
- slot &key (database *default-database*))
- (let* ((view-class (find-class (class-name (class-of instance))))
- (view-table (sql-expression :table (view-table view-class)))
- (vd (or (view-database instance) database))
- (view-qual (key-qualifier-for-instance instance :database vd))
- (slot-def (slotdef-for-slot-with-class slot view-class))
- (att-ref (generate-attribute-reference view-class slot-def))
- (res (select att-ref :from view-table :where view-qual
- :result-types nil)))
- (when res
- (get-slot-values-from-view instance (list slot-def) (car res)))))
-
-
-(defmethod update-slot-with-null ((object standard-db-object)
- slotname
- slotdef)
- (setf (slot-value object slotname) (slot-value slotdef 'void-value)))
-
-(defvar +no-slot-value+ '+no-slot-value+)
-
-(defsql sql-slot-value (:symbol "slot-value") (classname slot &optional (value +no-slot-value+) (database *default-database*))
- (let* ((class (find-class classname))
- (sld (slotdef-for-slot-with-class slot class)))
- (if sld
- (if (eq value +no-slot-value+)
- (sql-expression :attribute (view-class-slot-column sld)
- :table (view-table class))
- (db-value-from-slot
- sld
- value
- database))
- (error "Unknown slot ~A for class ~A" slot classname))))
-
-(defsql sql-view-class (:symbol "view-class") (classname &optional (database *default-database*))
- (declare (ignore database))
- (let* ((class (find-class classname)))
- (unless (view-table class)
- (error "No view-table for class ~A" classname))
- (sql-expression :table (view-table class))))
-
-(defmethod database-get-type-specifier (type args database db-type)
- (declare (ignore type args database db-type))
- "VARCHAR(255)")
-
-(defmethod database-get-type-specifier ((type (eql 'integer)) args database db-type)
- (declare (ignore database db-type))
- (if args
- (format nil "INT(~A)" (car args))
- "INT"))
-
-(deftype bigint ()
- "An integer larger than a 32-bit integer, this width may vary by SQL implementation."
- 'integer)
-
-(defmethod database-get-type-specifier ((type (eql 'bigint)) args database db-type)
- (declare (ignore args database db-type))
- "BIGINT")
-
-(defmethod database-get-type-specifier ((type (eql 'simple-base-string)) args
- database db-type)
- (declare (ignore database db-type))
- (if args
- (format nil "VARCHAR(~A)" (car args))
- "VARCHAR(255)"))
-
-(defmethod database-get-type-specifier ((type (eql 'simple-string)) args
- database db-type)
- (declare (ignore database db-type))
- (if args
- (format nil "VARCHAR(~A)" (car args))
- "VARCHAR(255)"))
-
-(defmethod database-get-type-specifier ((type (eql 'string)) args database db-type)
- (declare (ignore database db-type))
- (if args
- (format nil "VARCHAR(~A)" (car args))
- "VARCHAR(255)"))
-
-(deftype universal-time ()
- "A positive integer as returned by GET-UNIVERSAL-TIME."
- '(integer 1 *))
-
-(defmethod database-get-type-specifier ((type (eql 'universal-time)) args database db-type)
- (declare (ignore args database db-type))
- "BIGINT")
-
-(defmethod database-get-type-specifier ((type (eql 'wall-time)) args database db-type)
- (declare (ignore args database db-type))
- "TIMESTAMP")
-
-(defmethod database-get-type-specifier ((type (eql 'duration)) args database db-type)
- (declare (ignore database args db-type))
- "VARCHAR")
-
-(defmethod database-get-type-specifier ((type (eql 'money)) args database db-type)
- (declare (ignore database args db-type))
- "INT8")
-
-(deftype raw-string (&optional len)
- "A string which is not trimmed when retrieved from the database"
- `(string ,len))
-
-(defmethod database-get-type-specifier ((type (eql 'raw-string)) args database db-type)
- (declare (ignore database db-type))
- (if args
- (format nil "VARCHAR(~A)" (car args))
- "VARCHAR"))
-
-(defmethod database-get-type-specifier ((type (eql 'float)) args database db-type)
- (declare (ignore database db-type))
- (if args
- (format nil "FLOAT(~A)" (car args))
- "FLOAT"))
-
-(defmethod database-get-type-specifier ((type (eql 'long-float)) args database db-type)
- (declare (ignore database db-type))
- (if args
- (format nil "FLOAT(~A)" (car args))
- "FLOAT"))
-
-(defmethod database-get-type-specifier ((type (eql 'boolean)) args database db-type)
- (declare (ignore args database db-type))
- "BOOL")
-
-(defmethod database-output-sql-as-type (type val database db-type)
- (declare (ignore type database db-type))
- val)
-
-(defmethod database-output-sql-as-type ((type (eql 'list)) val database db-type)
- (declare (ignore database db-type))
- (progv '(*print-circle* *print-array*) '(t t)
- (let ((escaped (prin1-to-string val)))
- (substitute-char-string
- escaped #\Null " "))))
-
-(defmethod database-output-sql-as-type ((type (eql 'symbol)) val database db-type)
- (declare (ignore database db-type))
- (if (keywordp val)
- (symbol-name val)
- (if val
- (concatenate 'string
- (package-name (symbol-package val))
- "::"
- (symbol-name val))
- "")))
-
-(defmethod database-output-sql-as-type ((type (eql 'keyword)) val database db-type)
- (declare (ignore database db-type))
- (if val
- (symbol-name val)
- ""))
-
-(defmethod database-output-sql-as-type ((type (eql 'vector)) val database db-type)
- (declare (ignore database db-type))
- (progv '(*print-circle* *print-array*) '(t t)
- (prin1-to-string val)))
-
-(defmethod database-output-sql-as-type ((type (eql 'array)) val database db-type)
- (declare (ignore database db-type))
- (progv '(*print-circle* *print-array*) '(t t)
- (prin1-to-string val)))
-
-(defmethod database-output-sql-as-type ((type (eql 'boolean)) val database db-type)
- (declare (ignore database db-type))
- (if val "t" "f"))
-
-(defmethod database-output-sql-as-type ((type (eql 'string)) val database db-type)
- (declare (ignore database db-type))
- val)
-
-(defmethod database-output-sql-as-type ((type (eql 'simple-string))
- val database db-type)
- (declare (ignore database db-type))
- val)
-
-(defmethod database-output-sql-as-type ((type (eql 'simple-base-string))
- val database db-type)
- (declare (ignore database db-type))
- val)
-
-(defmethod read-sql-value (val type database db-type)
- (declare (ignore type database db-type))
- (read-from-string val))
-
-(defmethod read-sql-value (val (type (eql 'string)) database db-type)
- (declare (ignore database db-type))
- val)
-
-(defmethod read-sql-value (val (type (eql 'simple-string)) database db-type)
- (declare (ignore database db-type))
- val)
-
-(defmethod read-sql-value (val (type (eql 'simple-base-string)) database db-type)
- (declare (ignore database db-type))
- val)
-
-(defmethod read-sql-value (val (type (eql 'raw-string)) database db-type)
- (declare (ignore database db-type))
- val)
-
-(defmethod read-sql-value (val (type (eql 'keyword)) database db-type)
- (declare (ignore database db-type))
- (when (< 0 (length val))
- (intern (symbol-name-default-case val)
- (find-package '#:keyword))))
-
-(defmethod read-sql-value (val (type (eql 'symbol)) database db-type)
- (declare (ignore database db-type))
- (when (< 0 (length val))
- (unless (string= val (symbol-name-default-case "NIL"))
- (intern (symbol-name-default-case val)
- (symbol-package *update-context*)))))
-
-(defmethod read-sql-value (val (type (eql 'integer)) database db-type)
- (declare (ignore database db-type))
- (etypecase val
- (string
- (unless (string-equal "NIL" val)
- (parse-integer val)))
- (number val)))
-
-(defmethod read-sql-value (val (type (eql 'bigint)) database db-type)
- (declare (ignore database db-type))
- (etypecase val
- (string
- (unless (string-equal "NIL" val)
- (parse-integer val)))
- (number val)))
-
-(defmethod read-sql-value (val (type (eql 'float)) database db-type)
- (declare (ignore database db-type))
- ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...)
- (etypecase val
- (string
- (float (read-from-string val)))
- (float
- val)))
-
-(defmethod read-sql-value (val (type (eql 'boolean)) database db-type)
- (declare (ignore database db-type))
- (equal "t" val))
-
-(defmethod read-sql-value (val (type (eql 'univeral-time)) database db-type)
- (declare (ignore database db-type))
- (unless (eq 'NULL val)
- (etypecase val
- (string
- (parse-integer val))
- (number val))))
-
-(defmethod read-sql-value (val (type (eql 'wall-time)) database db-type)
- (declare (ignore database db-type))
- (unless (eq 'NULL val)
- (parse-timestring val)))
-
-(defmethod read-sql-value (val (type (eql 'duration)) database db-type)
- (declare (ignore database db-type))
- (unless (or (eq 'NULL val)
- (equal "NIL" val))
- (parse-timestring val)))
-
-;; ------------------------------------------------------------
-;; Logic for 'faulting in' :join slots
-
-;; this works, but is inefficient requiring (+ 1 n-rows)
-;; SQL queries
-#+ignore
-(defun fault-join-target-slot (class object slot-def)
- (let* ((res (fault-join-slot-raw class object slot-def))
- (dbi (view-class-slot-db-info slot-def))
- (target-name (gethash :target-slot dbi))
- (target-class (find-class target-name)))
- (when res
- (mapcar (lambda (obj)
- (list
- (car
- (fault-join-slot-raw
- target-class
- obj
- (find target-name (class-slots (class-of obj))
- :key #'slot-definition-name)))
- obj))
- res)
- #+ignore ;; this doesn't work when attempting to call slot-value
- (mapcar (lambda (obj)
- (cons obj (slot-value obj ts))) res))))
-
-(defun fault-join-target-slot (class object slot-def)
- (let* ((dbi (view-class-slot-db-info slot-def))
- (ts (gethash :target-slot dbi))
- (jc (gethash :join-class dbi))
- (ts-view-table (view-table (find-class ts)))
- (jc-view-table (view-table (find-class jc)))
- (tdbi (view-class-slot-db-info
- (find ts (class-slots (find-class jc))
- :key #'slot-definition-name)))
- (retrieval (gethash :retrieval tdbi))
- (jq (join-qualifier class object slot-def))
- (key (slot-value object (gethash :home-key dbi))))
- (when jq
- (ecase retrieval
- (:immediate
- (let ((res
- (find-all (list ts)
- :inner-join (sql-expression :table jc-view-table)
- :on (sql-operation
- '==
- (sql-expression
- :attribute (gethash :foreign-key tdbi)
- :table ts-view-table)
- (sql-expression
- :attribute (gethash :home-key tdbi)
- :table jc-view-table))
- :where jq
- :result-types :auto)))
- (mapcar #'(lambda (i)
- (let* ((instance (car i))
- (jcc (make-instance jc :view-database (view-database instance))))
- (setf (slot-value jcc (gethash :foreign-key dbi))
- key)
- (setf (slot-value jcc (gethash :home-key tdbi))
- (slot-value instance (gethash :foreign-key tdbi)))
- (list instance jcc)))
- res)))
- (:deferred
- ;; just fill in minimal slots
- (mapcar
- #'(lambda (k)
- (let ((instance (make-instance ts :view-database (view-database object)))
- (jcc (make-instance jc :view-database (view-database object)))
- (fk (car k)))
- (setf (slot-value instance (gethash :home-key tdbi)) fk)
- (setf (slot-value jcc (gethash :foreign-key dbi))
- key)
- (setf (slot-value jcc (gethash :home-key tdbi))
- fk)
- (list instance jcc)))
- (select (sql-expression :attribute (gethash :foreign-key tdbi) :table jc-view-table)
- :from (sql-expression :table jc-view-table)
- :where jq)))))))
-
-
-;;; Remote Joins
-
-(defvar *default-update-objects-max-len* nil
- "The default value to use for the MAX-LEN keyword argument to
- UPDATE-OBJECT-JOINS.")
-
-(defun update-objects-joins (objects &key (slots t) (force-p t)
- class-name (max-len
- *default-update-objects-max-len*))
- "Updates from the records of the appropriate database tables
-the join slots specified by SLOTS in the supplied list of View
-Class instances OBJECTS. SLOTS is t by default which means that
-all join slots with :retrieval :immediate are updated. CLASS-NAME
-is used to specify the View Class of all instance in OBJECTS and
-default to nil which means that the class of the first instance
-in OBJECTS is used. FORCE-P is t by default which means that all
-join slots are updated whereas a value of nil means that only
-unbound join slots are updated. MAX-LEN defaults to
-*DEFAULT-UPDATE-OBJECTS-MAX-LEN* and when non-nil specifies that
-UPDATE-OBJECT-JOINS may issue multiple database queries with a
-maximum of MAX-LEN instances updated in each query."
- (assert (or (null max-len) (plusp max-len)))
- (when objects
- (unless class-name
- (setq class-name (class-name (class-of (first objects)))))
- (let* ((class (find-class class-name))
- (class-slots (ordered-class-slots class))
- (slotdefs
- (if (eq t slots)
- (generate-retrieval-joins-list class :deferred)
- (remove-if #'null
- (mapcar #'(lambda (name)
- (let ((slotdef (find name class-slots :key #'slot-definition-name)))
- (unless slotdef
- (warn "Unable to find slot named ~S in class ~S." name class))
- slotdef))
- slots)))))
- (dolist (slotdef slotdefs)
- (let* ((dbi (view-class-slot-db-info slotdef))
- (slotdef-name (slot-definition-name slotdef))
- (foreign-key (gethash :foreign-key dbi))
- (home-key (gethash :home-key dbi))
- (object-keys
- (remove-duplicates
- (if force-p
- (mapcar #'(lambda (o) (slot-value o home-key)) objects)
- (remove-if #'null
- (mapcar
- #'(lambda (o) (if (slot-boundp o slotdef-name)
- nil
- (slot-value o home-key)))
- objects)))))
- (n-object-keys (length object-keys))
- (query-len (or max-len n-object-keys)))
-
- (do ((i 0 (+ i query-len)))
- ((>= i n-object-keys))
- (let* ((keys (if max-len
- (subseq object-keys i (min (+ i query-len) n-object-keys))
- object-keys))
- (results (find-all (list (gethash :join-class dbi))
- :where (make-instance 'sql-relational-exp
- :operator 'in
- :sub-expressions (list (sql-expression :attribute foreign-key)
- keys))
- :result-types :auto
- :flatp t)))
- (dolist (object objects)
- (when (or force-p (not (slot-boundp object slotdef-name)))
- (let ((res (find (slot-value object home-key) results
- :key #'(lambda (res) (slot-value res foreign-key))
- :test #'equal)))
- (when res
- (setf (slot-value object slotdef-name) res)))))))))))
- (values))
-
-(defun fault-join-slot-raw (class object slot-def)
- (let* ((dbi (view-class-slot-db-info slot-def))
- (jc (gethash :join-class dbi)))
- (let ((jq (join-qualifier class object slot-def)))
- (when jq
- (select jc :where jq :flatp t :result-types nil)))))
-
-(defun fault-join-slot (class object slot-def)
- (let* ((dbi (view-class-slot-db-info slot-def))
- (ts (gethash :target-slot dbi)))
- (if (and ts (gethash :set dbi))
- (fault-join-target-slot class object slot-def)
- (let ((res (fault-join-slot-raw class object slot-def)))
- (when res
- (cond
- ((and ts (not (gethash :set dbi)))
- (mapcar (lambda (obj) (slot-value obj ts)) res))
- ((and (not ts) (not (gethash :set dbi)))
- (car res))
- ((and (not ts) (gethash :set dbi))
- res)))))))
-
-(defun join-qualifier (class object slot-def)
- (declare (ignore class))
- (let* ((dbi (view-class-slot-db-info slot-def))
- (jc (find-class (gethash :join-class dbi)))
- ;;(ts (gethash :target-slot dbi))
- ;;(tsdef (if ts (slotdef-for-slot-with-class ts jc)))
- (foreign-keys (gethash :foreign-key dbi))
- (home-keys (gethash :home-key dbi)))
- (when (every #'(lambda (slt)
- (and (slot-boundp object slt)
- (not (null (slot-value object slt)))))
- (if (listp home-keys) home-keys (list home-keys)))
- (let ((jc
- (mapcar #'(lambda (hk fk)
- (let ((fksd (slotdef-for-slot-with-class fk jc)))
- (sql-operation '==
- (typecase fk
- (symbol
- (sql-expression
- :attribute
- (view-class-slot-column fksd)
- :table (view-table jc)))
- (t fk))
- (typecase hk
- (symbol
- (slot-value object hk))
- (t
- hk)))))
- (if (listp home-keys)
- home-keys
- (list home-keys))
- (if (listp foreign-keys)
- foreign-keys
- (list foreign-keys)))))
- (when jc
- (if (> (length jc) 1)
- (apply #'sql-and jc)
- jc))))))
-
-;; FIXME: add retrieval immediate for efficiency
-;; For example, for (select 'employee-address) in test suite =>
-;; select addr.*,ea_join.* FROM addr,ea_join WHERE ea_join.aaddressid=addr.addressid\g
-
-(defun build-objects (vals sclasses immediate-join-classes sels immediate-joins database refresh flatp instances)
- "Used by find-all to build objects."
- (labels ((build-object (vals vclass jclasses selects immediate-selects instance)
- (let* ((db-vals (butlast vals (- (list-length vals)
- (list-length selects))))
- (obj (if instance instance (make-instance (class-name vclass) :view-database database)))
- (join-vals (subseq vals (list-length selects)))
- (joins (mapcar #'(lambda (c) (when c (make-instance c :view-database database)))
- jclasses)))
- ;;(format t "db-vals: ~S, join-values: ~S~%" db-vals join-vals)
- ;; use refresh keyword here
- (setf obj (get-slot-values-from-view obj (mapcar #'car selects) db-vals))
- (mapc #'(lambda (jc) (get-slot-values-from-view jc (mapcar #'car immediate-selects) join-vals))
- joins)
- (mapc
- #'(lambda (jc)
- (let ((slot (find (class-name (class-of jc)) (class-slots vclass)
- :key #'(lambda (slot)
- (when (and (eq :join (view-class-slot-db-kind slot))
- (eq (slot-definition-name slot)
- (gethash :join-class (view-class-slot-db-info slot))))
- (slot-definition-name slot))))))
- (when slot
- (setf (slot-value obj (slot-definition-name slot)) jc))))
- joins)
- (when refresh (instance-refreshed obj))
- obj)))
- (let* ((objects
- (mapcar #'(lambda (sclass jclass sel immediate-join instance)
- (prog1
- (build-object vals sclass jclass sel immediate-join instance)
- (setf vals (nthcdr (+ (list-length sel) (list-length immediate-join))
- vals))))
- sclasses immediate-join-classes sels immediate-joins instances)))
- (if (and flatp (= (length sclasses) 1))
- (car objects)
- objects))))
-
-(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)
- "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)
- (optimize (debug 3) (speed 1)))
- (labels ((ref-equal (ref1 ref2)
- (equal (sql ref1)
- (sql ref2)))
- (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)
- (mapcar #'(lambda (jcs)
- (mapcan #'(lambda (jc)
- (when jc (table-sql-expr jc)))
- jcs))
- immediate-join-classes)
- sel-tables)
- :test #'tables-equal)))
- (order-by-slots (mapcar #'(lambda (ob) (if (atom ob) ob (car ob)))
- (listify order-by))))
-
- (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 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 where (listify where))))))
- jclasses jslots)))
- sclasses immediate-join-classes immediate-join-slots)
- (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)))
-
-(defun select (&rest select-all-args)
- "Executes a query on DATABASE, which has a default value of
-*DEFAULT-DATABASE*, specified by the SQL expressions supplied
-using the remaining arguments in SELECT-ALL-ARGS. The SELECT
-argument can be used to generate queries in both functional and
-object oriented contexts.
-
-In the functional case, the required arguments specify the
-columns selected by the query and may be symbolic SQL expressions
-or strings representing attribute identifiers. Type modified
-identifiers indicate that the values selected from the specified
-column are converted to the specified lisp type. The keyword
-arguments ALL, DISTINCT, FROM, GROUP-by, HAVING, ORDER-BY,
-SET-OPERATION and WHERE are used to specify, using the symbolic
-SQL syntax, the corresponding components of the SQL query
-generated by the call to SELECT. RESULT-TYPES is a list of
-symbols which specifies the lisp type for each field returned by
-the query. If RESULT-TYPES is nil all results are returned as
-strings whereas the default value of :auto means that the lisp
-types are automatically computed for each field. FIELD-NAMES is t
-by default which means that the second value returned is a list
-of strings representing the columns selected by the query. If
-FIELD-NAMES is nil, the list of column names is not returned as a
-second value.
-
-In the object oriented case, the required arguments to SELECT are
-symbols denoting View Classes which specify the database tables
-to query. In this case, SELECT returns a list of View Class
-instances whose slots are set from the attribute values of the
-records in the specified table. Slot-value is a legal operator
-which can be employed as part of the symbolic SQL syntax used in
-the WHERE keyword argument to SELECT. REFRESH is nil by default
-which means that the View Class instances returned are retrieved
-from a cache if an equivalent call to SELECT has previously been
-issued. If REFRESH is true, the View Class instances returned are
-updated as necessary from the database and the generic function
-INSTANCE-REFRESHED is called to perform any necessary operations
-on the updated instances.
-
-In both object oriented and functional contexts, FLATP has a
-default value of nil which means that the results are returned as
-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."
-
- (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))
-
- (cond
- ((select-objects target-args)
- (let ((caching (getf qualifier-args :caching t))
- (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
- (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)
- do (etypecase (nth i order-by-list)
- (sql-ident-attribute
- (unless (slot-value (nth i order-by-list) 'qualifier)
- (setf (slot-value (nth i order-by-list) 'qualifier) table-name)))
- (cons
- (unless (slot-value (car (nth i order-by-list)) 'qualifier)
- (setf (slot-value (car (nth i order-by-list)) 'qualifier) table-name)))))
- (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))))
- (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)))))
- (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)))))
- (setf (records-cache-results target-args qualifier-args database) results)
- results))))))))
- (t
- (let* ((expr (apply #'make-query 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))))))))
-
-(defun compute-records-cache-key (targets qualifiers)
- (list targets
- (do ((args *select-arguments* (cdr args))
- (results nil))
- ((null args) results)
- (let* ((arg (car args))
- (value (getf qualifiers arg)))
- (when value
- (push (list arg
- (typecase value
- (cons (cons (sql (car value)) (cdr value)))
- (%sql-expression (sql value))
- (t value)))
- results))))))
-
-(defun records-cache-results (targets qualifiers database)
- (when (record-caches database)
- (gethash (compute-records-cache-key targets qualifiers) (record-caches database))))
-
-(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)))
- (setf (gethash (compute-records-cache-key targets qualifiers)
- (record-caches database)) results)
- results)
-
-(defun update-cached-results (targets qualifiers database)
- ;; FIXME: this routine will need to update slots in cached objects, perhaps adding or removing objects from cached
- ;; for now, dump cache entry and perform fresh search
- (let ((res (apply #'find-all targets qualifiers)))
- (setf (gethash (compute-records-cache-key targets qualifiers)
- (record-caches database)) res)
- res))
-
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;;
+;;;; $Id:
+;;;;
+;;;; The CLSQL Object Oriented Data Definitional Language (OODDL)
+;;;;
+;;;; This file is part of CLSQL.
+;;;;
+;;;; CLSQL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+
+(in-package #:clsql-sys)
+
+(defclass standard-db-object ()
+ ((view-database :initform nil :initarg :view-database :reader view-database
+ :db-kind :virtual))
+ (:metaclass standard-db-class)
+ (:documentation "Superclass for all CLSQL View Classes."))
+
+(defvar *db-auto-sync* nil
+ "A non-nil value means that creating View Class instances or
+ setting their slots automatically creates/updates the
+ corresponding records in the underlying database.")
+
+(defvar *db-deserializing* nil)
+(defvar *db-initializing* nil)
+
+(defmethod slot-value-using-class ((class standard-db-class) instance slot-def)
+ (declare (optimize (speed 3)))
+ (unless *db-deserializing*
+ (let* ((slot-name (%svuc-slot-name slot-def))
+ (slot-object (%svuc-slot-object slot-def class))
+ (slot-kind (view-class-slot-db-kind slot-object)))
+ (when (and (eql slot-kind :join)
+ (not (slot-boundp instance slot-name)))
+ (let ((*db-deserializing* t))
+ (if (view-database instance)
+ (setf (slot-value instance slot-name)
+ (fault-join-slot class instance slot-object))
+ (setf (slot-value instance slot-name) nil))))))
+ (call-next-method))
+
+(defmethod (setf slot-value-using-class) (new-value (class standard-db-class)
+ instance slot-def)
+ (declare (ignore new-value))
+ (let* ((slot-name (%svuc-slot-name slot-def))
+ (slot-object (%svuc-slot-object slot-def class))
+ (slot-kind (view-class-slot-db-kind slot-object)))
+ (call-next-method)
+ (when (and *db-auto-sync*
+ (not *db-initializing*)
+ (not *db-deserializing*)
+ (not (eql slot-kind :virtual)))
+ (update-record-from-slot instance slot-name))))
+
+(defmethod initialize-instance ((object standard-db-object)
+ &rest all-keys &key &allow-other-keys)
+ (declare (ignore all-keys))
+ (let ((*db-initializing* t))
+ (call-next-method)
+ (when (and *db-auto-sync*
+ (not *db-deserializing*))
+ (update-records-from-instance object))))
+
+;;
+;; Build the database tables required to store the given view class
+;;
+
+(defun create-view-from-class (view-class-name
+ &key (database *default-database*))
+ "Creates a table as defined by the View Class VIEW-CLASS-NAME
+in DATABASE which defaults to *DEFAULT-DATABASE*."
+ (let ((tclass (find-class view-class-name)))
+ (if tclass
+ (let ((*default-database* database))
+ (%install-class tclass database))
+ (error "Class ~s not found." view-class-name)))
+ (values))
+
+(defmethod %install-class ((self standard-db-class) database &aux schemadef)
+ (dolist (slotdef (ordered-class-slots self))
+ (let ((res (database-generate-column-definition (class-name self)
+ slotdef database)))
+ (when res
+ (push res schemadef))))
+ (unless schemadef
+ (error "Class ~s has no :base slots" self))
+ (create-table (sql-expression :table (view-table self)) (nreverse schemadef)
+ :database database
+ :constraints (database-pkey-constraint self database))
+ (push self (database-view-classes database))
+ t)
+
+(defmethod database-pkey-constraint ((class standard-db-class) database)
+ (let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class))))
+ (when keylist
+ (convert-to-db-default-case
+ (format nil "CONSTRAINT ~APK PRIMARY KEY~A"
+ (database-output-sql (view-table class) database)
+ (database-output-sql keylist database))
+ database))))
+
+(defmethod database-generate-column-definition (class slotdef database)
+ (declare (ignore database class))
+ (when (member (view-class-slot-db-kind slotdef) '(:base :key))
+ (let ((cdef
+ (list (sql-expression :attribute (view-class-slot-column slotdef))
+ (specified-type slotdef))))
+ (setf cdef (append cdef (list (view-class-slot-db-type slotdef))))
+ (let ((const (view-class-slot-db-constraints slotdef)))
+ (when const
+ (setq cdef (append cdef (list const)))))
+ cdef)))
+
+
+;;
+;; Drop the tables which store the given view class
+;;
+
+(defun drop-view-from-class (view-class-name &key (database *default-database*))
+ "Removes a table defined by the View Class VIEW-CLASS-NAME from
+DATABASE which defaults to *DEFAULT-DATABASE*."
+ (let ((tclass (find-class view-class-name)))
+ (if tclass
+ (let ((*default-database* database))
+ (%uninstall-class tclass))
+ (error "Class ~s not found." view-class-name)))
+ (values))
+
+(defun %uninstall-class (self &key (database *default-database*))
+ (drop-table (sql-expression :table (view-table self))
+ :if-does-not-exist :ignore
+ :database database)
+ (setf (database-view-classes database)
+ (remove self (database-view-classes database))))
+
+
+;;
+;; List all known view classes
+;;
+
+(defun list-classes (&key (test #'identity)
+ (root-class (find-class 'standard-db-object))
+ (database *default-database*))
+ "Returns a list of all the View Classes which are connected to
+DATABASE, which defaults to *DEFAULT-DATABASE*, and which descend
+from the class ROOT-CLASS and which satisfy the function TEST. By
+default ROOT-CLASS is STANDARD-DB-OBJECT and TEST is IDENTITY."
+ (flet ((find-superclass (class)
+ (member root-class (class-precedence-list class))))
+ (let ((view-classes (and database (database-view-classes database))))
+ (when view-classes
+ (remove-if #'(lambda (c) (or (not (funcall test c))
+ (not (find-superclass c))))
+ view-classes)))))
+
+;;
+;; Define a new view class
+;;
+
+(defmacro def-view-class (class supers slots &rest cl-options)
+ "Creates a View Class called CLASS whose slots SLOTS can map
+onto the attributes of a table in a database. If SUPERS is nil
+then the superclass of CLASS will be STANDARD-DB-OBJECT,
+otherwise SUPERS is a list of superclasses for CLASS which must
+include STANDARD-DB-OBJECT or a descendent of this class. The
+syntax of DEFCLASS is extended through the addition of a class
+option :base-table which defines the database table onto which
+the View Class maps and which defaults to CLASS. The DEFCLASS
+syntax is also extended through additional slot
+options. The :db-kind slot option specifies the kind of DB
+mapping which is performed for this slot and defaults to :base
+which indicates that the slot maps to an ordinary column of the
+database table. A :db-kind value of :key indicates that this slot
+is a special kind of :base slot which maps onto a column which is
+one of the unique keys for the database table, the value :join
+indicates this slot represents a join onto another View Class
+which contains View Class objects, and the value :virtual
+indicates a standard CLOS slot which does not map onto columns of
+the database table. If a slot is specified with :db-kind :join,
+the slot option :db-info contains a list which specifies the
+nature of the join. For slots of :db-kind :base or :key,
+the :type slot option has a special interpretation such that Lisp
+types, such as string, integer and float are automatically
+converted into appropriate SQL types for the column onto which
+the slot maps. This behaviour may be over-ridden using
+the :db-type slot option which is a string specifying the
+vendor-specific database type for this slot's column definition
+in the database. The :column slot option specifies the name of
+the SQL column which the slot maps onto, if :db-kind is
+not :virtual, and defaults to the slot name. The :void-value slot
+option specifies the value to store if the SQL value is NULL and
+defaults to NIL. The :db-constraints slot option is a string
+representing an SQL table constraint expression or a list of such
+strings."
+ `(progn
+ (defclass ,class ,supers ,slots
+ ,@(if (find :metaclass `,cl-options :key #'car)
+ `,cl-options
+ (cons '(:metaclass clsql-sys::standard-db-class) `,cl-options)))
+ (finalize-inheritance (find-class ',class))
+ (find-class ',class)))
+
+(defun keyslots-for-class (class)
+ (slot-value class 'key-slots))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;;
+;;;; $Id:
+;;;;
+;;;; The CLSQL Object Oriented Data Manipulation Language (OODML).
+;;;;
+;;;; This file is part of CLSQL.
+;;;;
+;;;; CLSQL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package #:clsql-sys)
+
+
+(defun key-qualifier-for-instance (obj &key (database *default-database*))
+ (let ((tb (view-table (class-of obj))))
+ (flet ((qfk (k)
+ (sql-operation '==
+ (sql-expression :attribute
+ (view-class-slot-column k)
+ :table tb)
+ (db-value-from-slot
+ k
+ (slot-value obj (slot-definition-name k))
+ database))))
+ (let* ((keys (keyslots-for-class (class-of obj)))
+ (keyxprs (mapcar #'qfk (reverse keys))))
+ (cond
+ ((= (length keyxprs) 0) nil)
+ ((= (length keyxprs) 1) (car keyxprs))
+ ((> (length keyxprs) 1) (apply #'sql-operation 'and keyxprs)))))))
+
+;;
+;; Function used by 'generate-selection-list'
+;;
+
+(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)))
+ ((eq (view-class-slot-db-kind slotdef) :key)
+ (sql-expression :attribute (view-class-slot-column slotdef)
+ :table (view-table vclass)))
+ (t nil)))
+
+;;
+;; Function used by 'find-all'
+;;
+
+(defun generate-selection-list (vclass)
+ (let ((sels nil))
+ (dolist (slotdef (ordered-class-slots vclass))
+ (let ((res (generate-attribute-reference vclass slotdef)))
+ (when res
+ (push (cons slotdef res) sels))))
+ (if sels
+ sels
+ (error "No slots of type :base in view-class ~A" (class-name vclass)))))
+
+
+
+(defun generate-retrieval-joins-list (vclass retrieval-method)
+ "Returns list of immediate join slots for a class."
+ (let ((join-slotdefs nil))
+ (dolist (slotdef (ordered-class-slots vclass) join-slotdefs)
+ (when (and (eq :join (view-class-slot-db-kind slotdef))
+ (eq retrieval-method (gethash :retrieval (view-class-slot-db-info slotdef))))
+ (push slotdef join-slotdefs)))))
+
+(defun generate-immediate-joins-selection-list (vclass)
+ "Returns list of immediate join slots for a class."
+ (let (sels)
+ (dolist (joined-slot (generate-retrieval-joins-list vclass :immediate) sels)
+ (let* ((join-class-name (gethash :join-class (view-class-slot-db-info joined-slot)))
+ (join-class (when join-class-name (find-class join-class-name))))
+ (dolist (slotdef (ordered-class-slots join-class))
+ (let ((res (generate-attribute-reference join-class slotdef)))
+ (when res
+ (push (cons slotdef res) sels))))))
+ sels))
+
+
+;; Called by 'get-slot-values-from-view'
+;;
+
+(defvar *update-context* nil)
+
+(defmethod update-slot-from-db ((instance standard-db-object) slotdef value)
+ (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
+ (let* ((slot-reader (view-class-slot-db-reader slotdef))
+ (slot-name (slot-definition-name slotdef))
+ (slot-type (specified-type slotdef))
+ (*update-context* (cons (type-of instance) slot-name)))
+ (cond ((and value (null slot-reader))
+ (setf (slot-value instance slot-name)
+ (read-sql-value value (delistify slot-type)
+ (view-database instance)
+ (database-underlying-type
+ (view-database instance)))))
+ ((null value)
+ (update-slot-with-null instance slot-name slotdef))
+ ((typep slot-reader 'string)
+ (setf (slot-value instance slot-name)
+ (format nil slot-reader value)))
+ ((typep slot-reader 'function)
+ (setf (slot-value instance slot-name)
+ (apply slot-reader (list value))))
+ (t
+ (error "Slot reader is of an unusual type.")))))
+
+(defmethod key-value-from-db (slotdef value database)
+ (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
+ (let ((slot-reader (view-class-slot-db-reader slotdef))
+ (slot-type (specified-type slotdef)))
+ (cond ((and value (null slot-reader))
+ (read-sql-value value (delistify slot-type) database
+ (database-underlying-type database)))
+ ((null value)
+ nil)
+ ((typep slot-reader 'string)
+ (format nil slot-reader value))
+ ((typep slot-reader 'function)
+ (apply slot-reader (list value)))
+ (t
+ (error "Slot reader is of an unusual type.")))))
+
+(defun db-value-from-slot (slotdef val database)
+ (let ((dbwriter (view-class-slot-db-writer slotdef))
+ (dbtype (specified-type slotdef)))
+ (typecase dbwriter
+ (string (format nil dbwriter val))
+ (function (apply dbwriter (list val)))
+ (t
+ (database-output-sql-as-type
+ (typecase dbtype
+ (cons (car dbtype))
+ (t dbtype))
+ val database (database-underlying-type database))))))
+
+(defun check-slot-type (slotdef val)
+ (let* ((slot-type (specified-type slotdef))
+ (basetype (if (listp slot-type) (car slot-type) slot-type)))
+ (when (and slot-type val)
+ (unless (typep val basetype)
+ (error 'sql-user-error
+ :message
+ (format nil "Invalid value ~A in slot ~A, not of type ~A."
+ val (slot-definition-name slotdef) slot-type))))))
+
+;;
+;; Called by find-all
+;;
+
+(defmethod get-slot-values-from-view (obj slotdeflist values)
+ (flet ((update-slot (slot-def values)
+ (update-slot-from-db obj slot-def values)))
+ (mapc #'update-slot slotdeflist values)
+ obj))
+
+(defmethod update-record-from-slot ((obj standard-db-object) slot &key
+ (database *default-database*))
+ (let* ((database (or (view-database obj) database))
+ (vct (view-table (class-of obj)))
+ (sd (slotdef-for-slot-with-class slot (class-of obj))))
+ (check-slot-type sd (slot-value obj slot))
+ (let* ((att (view-class-slot-column sd))
+ (val (db-value-from-slot sd (slot-value obj slot) database)))
+ (cond ((and vct sd (view-database obj))
+ (update-records (sql-expression :table vct)
+ :attributes (list (sql-expression :attribute att))
+ :values (list val)
+ :where (key-qualifier-for-instance
+ obj :database database)
+ :database database))
+ ((and vct sd (not (view-database obj)))
+ (insert-records :into (sql-expression :table vct)
+ :attributes (list (sql-expression :attribute att))
+ :values (list val)
+ :database database)
+ (setf (slot-value obj 'view-database) database))
+ (t
+ (error "Unable to update record.")))))
+ (values))
+
+(defmethod update-record-from-slots ((obj standard-db-object) slots &key
+ (database *default-database*))
+ (let* ((database (or (view-database obj) database))
+ (vct (view-table (class-of obj)))
+ (sds (slotdefs-for-slots-with-class slots (class-of obj)))
+ (avps (mapcar #'(lambda (s)
+ (let ((val (slot-value
+ obj (slot-definition-name s))))
+ (check-slot-type s val)
+ (list (sql-expression
+ :attribute (view-class-slot-column s))
+ (db-value-from-slot s val database))))
+ sds)))
+ (cond ((and avps (view-database obj))
+ (update-records (sql-expression :table vct)
+ :av-pairs avps
+ :where (key-qualifier-for-instance
+ obj :database database)
+ :database database))
+ ((and avps (not (view-database obj)))
+ (insert-records :into (sql-expression :table vct)
+ :av-pairs avps
+ :database database)
+ (setf (slot-value obj 'view-database) database))
+ (t
+ (error "Unable to update records"))))
+ (values))
+
+(defmethod update-records-from-instance ((obj standard-db-object)
+ &key (database *default-database*))
+ (let ((database (or (view-database obj) database)))
+ (labels ((slot-storedp (slot)
+ (and (member (view-class-slot-db-kind slot) '(:base :key))
+ (slot-boundp obj (slot-definition-name slot))))
+ (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))
+ (db-value-from-slot slot value database)))))
+ (let* ((view-class (class-of obj))
+ (view-class-table (view-table view-class))
+ (slots (remove-if-not #'slot-storedp
+ (ordered-class-slots view-class)))
+ (record-values (mapcar #'slot-value-list slots)))
+ (unless record-values
+ (error "No settable slots."))
+ (if (view-database obj)
+ (update-records (sql-expression :table view-class-table)
+ :av-pairs record-values
+ :where (key-qualifier-for-instance
+ obj :database database)
+ :database database)
+ (progn
+ (insert-records :into (sql-expression :table view-class-table)
+ :av-pairs record-values
+ :database database)
+ (setf (slot-value obj 'view-database) database))))))
+ (values))
+
+(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 (slot-value instance 'view-database) nil))
+ (signal-no-database-error vd))))
+
+(defmethod update-instance-from-records ((instance standard-db-object)
+ &key (database *default-database*))
+ (let* ((view-class (find-class (class-name (class-of instance))))
+ (view-table (sql-expression :table (view-table view-class)))
+ (vd (or (view-database instance) database))
+ (view-qual (key-qualifier-for-instance instance :database vd))
+ (sels (generate-selection-list view-class))
+ (res (apply #'select (append (mapcar #'cdr sels)
+ (list :from view-table
+ :where view-qual)
+ (list :result-types nil)))))
+ (when res
+ (get-slot-values-from-view instance (mapcar #'car sels) (car res)))))
+
+(defmethod update-slot-from-record ((instance standard-db-object)
+ slot &key (database *default-database*))
+ (let* ((view-class (find-class (class-name (class-of instance))))
+ (view-table (sql-expression :table (view-table view-class)))
+ (vd (or (view-database instance) database))
+ (view-qual (key-qualifier-for-instance instance :database vd))
+ (slot-def (slotdef-for-slot-with-class slot view-class))
+ (att-ref (generate-attribute-reference view-class slot-def))
+ (res (select att-ref :from view-table :where view-qual
+ :result-types nil)))
+ (when res
+ (get-slot-values-from-view instance (list slot-def) (car res)))))
+
+
+(defmethod update-slot-with-null ((object standard-db-object)
+ slotname
+ slotdef)
+ (setf (slot-value object slotname) (slot-value slotdef 'void-value)))
+
+(defvar +no-slot-value+ '+no-slot-value+)
+
+(defsql sql-slot-value (:symbol "slot-value") (classname slot &optional (value +no-slot-value+) (database *default-database*))
+ (let* ((class (find-class classname))
+ (sld (slotdef-for-slot-with-class slot class)))
+ (if sld
+ (if (eq value +no-slot-value+)
+ (sql-expression :attribute (view-class-slot-column sld)
+ :table (view-table class))
+ (db-value-from-slot
+ sld
+ value
+ database))
+ (error "Unknown slot ~A for class ~A" slot classname))))
+
+(defsql sql-view-class (:symbol "view-class") (classname &optional (database *default-database*))
+ (declare (ignore database))
+ (let* ((class (find-class classname)))
+ (unless (view-table class)
+ (error "No view-table for class ~A" classname))
+ (sql-expression :table (view-table class))))
+
+(defmethod database-get-type-specifier (type args database db-type)
+ (declare (ignore type args database db-type))
+ "VARCHAR(255)")
+
+(defmethod database-get-type-specifier ((type (eql 'integer)) args database db-type)
+ (declare (ignore database db-type))
+ (if args
+ (format nil "INT(~A)" (car args))
+ "INT"))
+
+(deftype bigint ()
+ "An integer larger than a 32-bit integer, this width may vary by SQL implementation."
+ 'integer)
+
+(defmethod database-get-type-specifier ((type (eql 'bigint)) args database db-type)
+ (declare (ignore args database db-type))
+ "BIGINT")
+
+(defmethod database-get-type-specifier ((type (eql 'simple-base-string)) args
+ database db-type)
+ (declare (ignore database db-type))
+ (if args
+ (format nil "VARCHAR(~A)" (car args))
+ "VARCHAR(255)"))
+
+(defmethod database-get-type-specifier ((type (eql 'simple-string)) args
+ database db-type)
+ (declare (ignore database db-type))
+ (if args
+ (format nil "VARCHAR(~A)" (car args))
+ "VARCHAR(255)"))
+
+(defmethod database-get-type-specifier ((type (eql 'string)) args database db-type)
+ (declare (ignore database db-type))
+ (if args
+ (format nil "VARCHAR(~A)" (car args))
+ "VARCHAR(255)"))
+
+(deftype universal-time ()
+ "A positive integer as returned by GET-UNIVERSAL-TIME."
+ '(integer 1 *))
+
+(defmethod database-get-type-specifier ((type (eql 'universal-time)) args database db-type)
+ (declare (ignore args database db-type))
+ "BIGINT")
+
+(defmethod database-get-type-specifier ((type (eql 'wall-time)) args database db-type)
+ (declare (ignore args database db-type))
+ "TIMESTAMP")
+
+(defmethod database-get-type-specifier ((type (eql 'duration)) args database db-type)
+ (declare (ignore database args db-type))
+ "VARCHAR")
+
+(defmethod database-get-type-specifier ((type (eql 'money)) args database db-type)
+ (declare (ignore database args db-type))
+ "INT8")
+
+(deftype raw-string (&optional len)
+ "A string which is not trimmed when retrieved from the database"
+ `(string ,len))
+
+(defmethod database-get-type-specifier ((type (eql 'raw-string)) args database db-type)
+ (declare (ignore database db-type))
+ (if args
+ (format nil "VARCHAR(~A)" (car args))
+ "VARCHAR"))
+
+(defmethod database-get-type-specifier ((type (eql 'float)) args database db-type)
+ (declare (ignore database db-type))
+ (if args
+ (format nil "FLOAT(~A)" (car args))
+ "FLOAT"))
+
+(defmethod database-get-type-specifier ((type (eql 'long-float)) args database db-type)
+ (declare (ignore database db-type))
+ (if args
+ (format nil "FLOAT(~A)" (car args))
+ "FLOAT"))
+
+(defmethod database-get-type-specifier ((type (eql 'boolean)) args database db-type)
+ (declare (ignore args database db-type))
+ "BOOL")
+
+(defmethod database-output-sql-as-type (type val database db-type)
+ (declare (ignore type database db-type))
+ val)
+
+(defmethod database-output-sql-as-type ((type (eql 'list)) val database db-type)
+ (declare (ignore database db-type))
+ (progv '(*print-circle* *print-array*) '(t t)
+ (let ((escaped (prin1-to-string val)))
+ (substitute-char-string
+ escaped #\Null " "))))
+
+(defmethod database-output-sql-as-type ((type (eql 'symbol)) val database db-type)
+ (declare (ignore database db-type))
+ (if (keywordp val)
+ (symbol-name val)
+ (if val
+ (concatenate 'string
+ (package-name (symbol-package val))
+ "::"
+ (symbol-name val))
+ "")))
+
+(defmethod database-output-sql-as-type ((type (eql 'keyword)) val database db-type)
+ (declare (ignore database db-type))
+ (if val
+ (symbol-name val)
+ ""))
+
+(defmethod database-output-sql-as-type ((type (eql 'vector)) val database db-type)
+ (declare (ignore database db-type))
+ (progv '(*print-circle* *print-array*) '(t t)
+ (prin1-to-string val)))
+
+(defmethod database-output-sql-as-type ((type (eql 'array)) val database db-type)
+ (declare (ignore database db-type))
+ (progv '(*print-circle* *print-array*) '(t t)
+ (prin1-to-string val)))
+
+(defmethod database-output-sql-as-type ((type (eql 'boolean)) val database db-type)
+ (declare (ignore database db-type))
+ (if val "t" "f"))
+
+(defmethod database-output-sql-as-type ((type (eql 'string)) val database db-type)
+ (declare (ignore database db-type))
+ val)
+
+(defmethod database-output-sql-as-type ((type (eql 'simple-string))
+ val database db-type)
+ (declare (ignore database db-type))
+ val)
+
+(defmethod database-output-sql-as-type ((type (eql 'simple-base-string))
+ val database db-type)
+ (declare (ignore database db-type))
+ val)
+
+(defmethod read-sql-value (val type database db-type)
+ (declare (ignore type database db-type))
+ (read-from-string val))
+
+(defmethod read-sql-value (val (type (eql 'string)) database db-type)
+ (declare (ignore database db-type))
+ val)
+
+(defmethod read-sql-value (val (type (eql 'simple-string)) database db-type)
+ (declare (ignore database db-type))
+ val)
+
+(defmethod read-sql-value (val (type (eql 'simple-base-string)) database db-type)
+ (declare (ignore database db-type))
+ val)
+
+(defmethod read-sql-value (val (type (eql 'raw-string)) database db-type)
+ (declare (ignore database db-type))
+ val)
+
+(defmethod read-sql-value (val (type (eql 'keyword)) database db-type)
+ (declare (ignore database db-type))
+ (when (< 0 (length val))
+ (intern (symbol-name-default-case val)
+ (find-package '#:keyword))))
+
+(defmethod read-sql-value (val (type (eql 'symbol)) database db-type)
+ (declare (ignore database db-type))
+ (when (< 0 (length val))
+ (unless (string= val (symbol-name-default-case "NIL"))
+ (intern (symbol-name-default-case val)
+ (symbol-package *update-context*)))))
+
+(defmethod read-sql-value (val (type (eql 'integer)) database db-type)
+ (declare (ignore database db-type))
+ (etypecase val
+ (string
+ (unless (string-equal "NIL" val)
+ (parse-integer val)))
+ (number val)))
+
+(defmethod read-sql-value (val (type (eql 'bigint)) database db-type)
+ (declare (ignore database db-type))
+ (etypecase val
+ (string
+ (unless (string-equal "NIL" val)
+ (parse-integer val)))
+ (number val)))
+
+(defmethod read-sql-value (val (type (eql 'float)) database db-type)
+ (declare (ignore database db-type))
+ ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...)
+ (etypecase val
+ (string
+ (float (read-from-string val)))
+ (float
+ val)))
+
+(defmethod read-sql-value (val (type (eql 'boolean)) database db-type)
+ (declare (ignore database db-type))
+ (equal "t" val))
+
+(defmethod read-sql-value (val (type (eql 'univeral-time)) database db-type)
+ (declare (ignore database db-type))
+ (unless (eq 'NULL val)
+ (etypecase val
+ (string
+ (parse-integer val))
+ (number val))))
+
+(defmethod read-sql-value (val (type (eql 'wall-time)) database db-type)
+ (declare (ignore database db-type))
+ (unless (eq 'NULL val)
+ (parse-timestring val)))
+
+(defmethod read-sql-value (val (type (eql 'duration)) database db-type)
+ (declare (ignore database db-type))
+ (unless (or (eq 'NULL val)
+ (equal "NIL" val))
+ (parse-timestring val)))
+
+;; ------------------------------------------------------------
+;; Logic for 'faulting in' :join slots
+
+;; this works, but is inefficient requiring (+ 1 n-rows)
+;; SQL queries
+#+ignore
+(defun fault-join-target-slot (class object slot-def)
+ (let* ((res (fault-join-slot-raw class object slot-def))
+ (dbi (view-class-slot-db-info slot-def))
+ (target-name (gethash :target-slot dbi))
+ (target-class (find-class target-name)))
+ (when res
+ (mapcar (lambda (obj)
+ (list
+ (car
+ (fault-join-slot-raw
+ target-class
+ obj
+ (find target-name (class-slots (class-of obj))
+ :key #'slot-definition-name)))
+ obj))
+ res)
+ #+ignore ;; this doesn't work when attempting to call slot-value
+ (mapcar (lambda (obj)
+ (cons obj (slot-value obj ts))) res))))
+
+(defun fault-join-target-slot (class object slot-def)
+ (let* ((dbi (view-class-slot-db-info slot-def))
+ (ts (gethash :target-slot dbi))
+ (jc (gethash :join-class dbi))
+ (ts-view-table (view-table (find-class ts)))
+ (jc-view-table (view-table (find-class jc)))
+ (tdbi (view-class-slot-db-info
+ (find ts (class-slots (find-class jc))
+ :key #'slot-definition-name)))
+ (retrieval (gethash :retrieval tdbi))
+ (jq (join-qualifier class object slot-def))
+ (key (slot-value object (gethash :home-key dbi))))
+ (when jq
+ (ecase retrieval
+ (:immediate
+ (let ((res
+ (find-all (list ts)
+ :inner-join (sql-expression :table jc-view-table)
+ :on (sql-operation
+ '==
+ (sql-expression
+ :attribute (gethash :foreign-key tdbi)
+ :table ts-view-table)
+ (sql-expression
+ :attribute (gethash :home-key tdbi)
+ :table jc-view-table))
+ :where jq
+ :result-types :auto)))
+ (mapcar #'(lambda (i)
+ (let* ((instance (car i))
+ (jcc (make-instance jc :view-database (view-database instance))))
+ (setf (slot-value jcc (gethash :foreign-key dbi))
+ key)
+ (setf (slot-value jcc (gethash :home-key tdbi))
+ (slot-value instance (gethash :foreign-key tdbi)))
+ (list instance jcc)))
+ res)))
+ (:deferred
+ ;; just fill in minimal slots
+ (mapcar
+ #'(lambda (k)
+ (let ((instance (make-instance ts :view-database (view-database object)))
+ (jcc (make-instance jc :view-database (view-database object)))
+ (fk (car k)))
+ (setf (slot-value instance (gethash :home-key tdbi)) fk)
+ (setf (slot-value jcc (gethash :foreign-key dbi))
+ key)
+ (setf (slot-value jcc (gethash :home-key tdbi))
+ fk)
+ (list instance jcc)))
+ (select (sql-expression :attribute (gethash :foreign-key tdbi) :table jc-view-table)
+ :from (sql-expression :table jc-view-table)
+ :where jq)))))))
+
+
+;;; Remote Joins
+
+(defvar *default-update-objects-max-len* nil
+ "The default value to use for the MAX-LEN keyword argument to
+ UPDATE-OBJECT-JOINS.")
+
+(defun update-objects-joins (objects &key (slots t) (force-p t)
+ class-name (max-len
+ *default-update-objects-max-len*))
+ "Updates from the records of the appropriate database tables
+the join slots specified by SLOTS in the supplied list of View
+Class instances OBJECTS. SLOTS is t by default which means that
+all join slots with :retrieval :immediate are updated. CLASS-NAME
+is used to specify the View Class of all instance in OBJECTS and
+default to nil which means that the class of the first instance
+in OBJECTS is used. FORCE-P is t by default which means that all
+join slots are updated whereas a value of nil means that only
+unbound join slots are updated. MAX-LEN defaults to
+*DEFAULT-UPDATE-OBJECTS-MAX-LEN* and when non-nil specifies that
+UPDATE-OBJECT-JOINS may issue multiple database queries with a
+maximum of MAX-LEN instances updated in each query."
+ (assert (or (null max-len) (plusp max-len)))
+ (when objects
+ (unless class-name
+ (setq class-name (class-name (class-of (first objects)))))
+ (let* ((class (find-class class-name))
+ (class-slots (ordered-class-slots class))
+ (slotdefs
+ (if (eq t slots)
+ (generate-retrieval-joins-list class :deferred)
+ (remove-if #'null
+ (mapcar #'(lambda (name)
+ (let ((slotdef (find name class-slots :key #'slot-definition-name)))
+ (unless slotdef
+ (warn "Unable to find slot named ~S in class ~S." name class))
+ slotdef))
+ slots)))))
+ (dolist (slotdef slotdefs)
+ (let* ((dbi (view-class-slot-db-info slotdef))
+ (slotdef-name (slot-definition-name slotdef))
+ (foreign-key (gethash :foreign-key dbi))
+ (home-key (gethash :home-key dbi))
+ (object-keys
+ (remove-duplicates
+ (if force-p
+ (mapcar #'(lambda (o) (slot-value o home-key)) objects)
+ (remove-if #'null
+ (mapcar
+ #'(lambda (o) (if (slot-boundp o slotdef-name)
+ nil
+ (slot-value o home-key)))
+ objects)))))
+ (n-object-keys (length object-keys))
+ (query-len (or max-len n-object-keys)))
+
+ (do ((i 0 (+ i query-len)))
+ ((>= i n-object-keys))
+ (let* ((keys (if max-len
+ (subseq object-keys i (min (+ i query-len) n-object-keys))
+ object-keys))
+ (results (find-all (list (gethash :join-class dbi))
+ :where (make-instance 'sql-relational-exp
+ :operator 'in
+ :sub-expressions (list (sql-expression :attribute foreign-key)
+ keys))
+ :result-types :auto
+ :flatp t)))
+ (dolist (object objects)
+ (when (or force-p (not (slot-boundp object slotdef-name)))
+ (let ((res (find (slot-value object home-key) results
+ :key #'(lambda (res) (slot-value res foreign-key))
+ :test #'equal)))
+ (when res
+ (setf (slot-value object slotdef-name) res)))))))))))
+ (values))
+
+(defun fault-join-slot-raw (class object slot-def)
+ (let* ((dbi (view-class-slot-db-info slot-def))
+ (jc (gethash :join-class dbi)))
+ (let ((jq (join-qualifier class object slot-def)))
+ (when jq
+ (select jc :where jq :flatp t :result-types nil)))))
+
+(defun fault-join-slot (class object slot-def)
+ (let* ((dbi (view-class-slot-db-info slot-def))
+ (ts (gethash :target-slot dbi)))
+ (if (and ts (gethash :set dbi))
+ (fault-join-target-slot class object slot-def)
+ (let ((res (fault-join-slot-raw class object slot-def)))
+ (when res
+ (cond
+ ((and ts (not (gethash :set dbi)))
+ (mapcar (lambda (obj) (slot-value obj ts)) res))
+ ((and (not ts) (not (gethash :set dbi)))
+ (car res))
+ ((and (not ts) (gethash :set dbi))
+ res)))))))
+
+(defun join-qualifier (class object slot-def)
+ (declare (ignore class))
+ (let* ((dbi (view-class-slot-db-info slot-def))
+ (jc (find-class (gethash :join-class dbi)))
+ ;;(ts (gethash :target-slot dbi))
+ ;;(tsdef (if ts (slotdef-for-slot-with-class ts jc)))
+ (foreign-keys (gethash :foreign-key dbi))
+ (home-keys (gethash :home-key dbi)))
+ (when (every #'(lambda (slt)
+ (and (slot-boundp object slt)
+ (not (null (slot-value object slt)))))
+ (if (listp home-keys) home-keys (list home-keys)))
+ (let ((jc
+ (mapcar #'(lambda (hk fk)
+ (let ((fksd (slotdef-for-slot-with-class fk jc)))
+ (sql-operation '==
+ (typecase fk
+ (symbol
+ (sql-expression
+ :attribute
+ (view-class-slot-column fksd)
+ :table (view-table jc)))
+ (t fk))
+ (typecase hk
+ (symbol
+ (slot-value object hk))
+ (t
+ hk)))))
+ (if (listp home-keys)
+ home-keys
+ (list home-keys))
+ (if (listp foreign-keys)
+ foreign-keys
+ (list foreign-keys)))))
+ (when jc
+ (if (> (length jc) 1)
+ (apply #'sql-and jc)
+ jc))))))
+
+;; FIXME: add retrieval immediate for efficiency
+;; For example, for (select 'employee-address) in test suite =>
+;; select addr.*,ea_join.* FROM addr,ea_join WHERE ea_join.aaddressid=addr.addressid\g
+
+(defun build-objects (vals sclasses immediate-join-classes sels immediate-joins database refresh flatp instances)
+ "Used by find-all to build objects."
+ (labels ((build-object (vals vclass jclasses selects immediate-selects instance)
+ (let* ((db-vals (butlast vals (- (list-length vals)
+ (list-length selects))))
+ (obj (if instance instance (make-instance (class-name vclass) :view-database database)))
+ (join-vals (subseq vals (list-length selects)))
+ (joins (mapcar #'(lambda (c) (when c (make-instance c :view-database database)))
+ jclasses)))
+ ;;(format t "db-vals: ~S, join-values: ~S~%" db-vals join-vals)
+ ;; use refresh keyword here
+ (setf obj (get-slot-values-from-view obj (mapcar #'car selects) db-vals))
+ (mapc #'(lambda (jc) (get-slot-values-from-view jc (mapcar #'car immediate-selects) join-vals))
+ joins)
+ (mapc
+ #'(lambda (jc)
+ (let ((slot (find (class-name (class-of jc)) (class-slots vclass)
+ :key #'(lambda (slot)
+ (when (and (eq :join (view-class-slot-db-kind slot))
+ (eq (slot-definition-name slot)
+ (gethash :join-class (view-class-slot-db-info slot))))
+ (slot-definition-name slot))))))
+ (when slot
+ (setf (slot-value obj (slot-definition-name slot)) jc))))
+ joins)
+ (when refresh (instance-refreshed obj))
+ obj)))
+ (let* ((objects
+ (mapcar #'(lambda (sclass jclass sel immediate-join instance)
+ (prog1
+ (build-object vals sclass jclass sel immediate-join instance)
+ (setf vals (nthcdr (+ (list-length sel) (list-length immediate-join))
+ vals))))
+ sclasses immediate-join-classes sels immediate-joins instances)))
+ (if (and flatp (= (length sclasses) 1))
+ (car objects)
+ objects))))
+
+(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)
+ "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)
+ (optimize (debug 3) (speed 1)))
+ (labels ((ref-equal (ref1 ref2)
+ (equal (sql ref1)
+ (sql ref2)))
+ (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)
+ (mapcar #'(lambda (jcs)
+ (mapcan #'(lambda (jc)
+ (when jc (table-sql-expr jc)))
+ jcs))
+ immediate-join-classes)
+ sel-tables)
+ :test #'tables-equal)))
+ (order-by-slots (mapcar #'(lambda (ob) (if (atom ob) ob (car ob)))
+ (listify order-by))))
+
+ (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 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 where (listify where))))))
+ jclasses jslots)))
+ sclasses immediate-join-classes immediate-join-slots)
+ (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)))
+
+(defun select (&rest select-all-args)
+ "Executes a query on DATABASE, which has a default value of
+*DEFAULT-DATABASE*, specified by the SQL expressions supplied
+using the remaining arguments in SELECT-ALL-ARGS. The SELECT
+argument can be used to generate queries in both functional and
+object oriented contexts.
+
+In the functional case, the required arguments specify the
+columns selected by the query and may be symbolic SQL expressions
+or strings representing attribute identifiers. Type modified
+identifiers indicate that the values selected from the specified
+column are converted to the specified lisp type. The keyword
+arguments ALL, DISTINCT, FROM, GROUP-by, HAVING, ORDER-BY,
+SET-OPERATION and WHERE are used to specify, using the symbolic
+SQL syntax, the corresponding components of the SQL query
+generated by the call to SELECT. RESULT-TYPES is a list of
+symbols which specifies the lisp type for each field returned by
+the query. If RESULT-TYPES is nil all results are returned as
+strings whereas the default value of :auto means that the lisp
+types are automatically computed for each field. FIELD-NAMES is t
+by default which means that the second value returned is a list
+of strings representing the columns selected by the query. If
+FIELD-NAMES is nil, the list of column names is not returned as a
+second value.
+
+In the object oriented case, the required arguments to SELECT are
+symbols denoting View Classes which specify the database tables
+to query. In this case, SELECT returns a list of View Class
+instances whose slots are set from the attribute values of the
+records in the specified table. Slot-value is a legal operator
+which can be employed as part of the symbolic SQL syntax used in
+the WHERE keyword argument to SELECT. REFRESH is nil by default
+which means that the View Class instances returned are retrieved
+from a cache if an equivalent call to SELECT has previously been
+issued. If REFRESH is true, the View Class instances returned are
+updated as necessary from the database and the generic function
+INSTANCE-REFRESHED is called to perform any necessary operations
+on the updated instances.
+
+In both object oriented and functional contexts, FLATP has a
+default value of nil which means that the results are returned as
+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."
+
+ (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))
+
+ (cond
+ ((select-objects target-args)
+ (let ((caching (getf qualifier-args :caching t))
+ (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
+ (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)
+ do (etypecase (nth i order-by-list)
+ (sql-ident-attribute
+ (unless (slot-value (nth i order-by-list) 'qualifier)
+ (setf (slot-value (nth i order-by-list) 'qualifier) table-name)))
+ (cons
+ (unless (slot-value (car (nth i order-by-list)) 'qualifier)
+ (setf (slot-value (car (nth i order-by-list)) 'qualifier) table-name)))))
+ (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))))
+ (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)))))
+ (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)))))
+ (setf (records-cache-results target-args qualifier-args database) results)
+ results))))))))
+ (t
+ (let* ((expr (apply #'make-query 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))))))))
+
+(defun compute-records-cache-key (targets qualifiers)
+ (list targets
+ (do ((args *select-arguments* (cdr args))
+ (results nil))
+ ((null args) results)
+ (let* ((arg (car args))
+ (value (getf qualifiers arg)))
+ (when value
+ (push (list arg
+ (typecase value
+ (cons (cons (sql (car value)) (cdr value)))
+ (%sql-expression (sql value))
+ (t value)))
+ results))))))
+
+(defun records-cache-results (targets qualifiers database)
+ (when (record-caches database)
+ (gethash (compute-records-cache-key targets qualifiers) (record-caches database))))
+
+(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)))
+ (setf (gethash (compute-records-cache-key targets qualifiers)
+ (record-caches database)) results)
+ results)
+
+(defun update-cached-results (targets qualifiers database)
+ ;; FIXME: this routine will need to update slots in cached objects, perhaps adding or removing objects from cached
+ ;; for now, dump cache entry and perform fresh search
+ (let ((res (apply #'find-all targets qualifiers)))
+ (setf (gethash (compute-records-cache-key targets qualifiers)
+ (record-caches database)) res)
+ res))
+
#:database-get-type-specifier
#:read-sql-value
#:database-output-sql-as-type
+ #:*loaded-database-types*
+ #:reload-database-types
+ #:is-database-open
;; Large objects
#:database-create-large-object
#:convert-to-db-default-case
#:ensure-keyword
#:getenv
-
- #:*loaded-database-types*
- #:reload-database-types
- #:*connect-if-exists*
- #:connected-databases
- #:database
- #:find-database
- #:is-database-open
- #:database-type ; database x
-
- ;; utils.lisp
#:number-to-sql-string
#:float-to-sql-string
#:sql-escape-quotes
#:generic-odbc-database
.
+
;; Shared exports for re-export by CLSQL package.
- ;; I = Implemented, D = Documented
- ;; name file ID
- ;;====================================================
- #1=(;;------------------------------------------------
- ;; CommonSQL API
- ;;------------------------------------------------
- ;;FDML
- #:select ; objects xx
- #:cache-table-queries ;
- #:*cache-table-queries-default* ;
- #:delete-records ; sql xx
- #:insert-records ; sql xx
- #:update-records ; sql xx
- #:execute-command ; sql xx
- #:query ; sql xx
- #:print-query ; sql xx
- #:do-query ; sql xx
- #:map-query ; sql xx
- #:for-each-row
- #:loop
+ #1=(
- ;; conditions
+ ;; Condition system (conditions.lisp)
#:sql-user-error
#:sql-database-error
#:sql-database-data-error
#:sql-connection-error
#:sql-temporary-error
+ #:sql-timeout-error
+ #:sql-fatal-error
#:sql-error-error-id
#:sql-error-secondary-error-id
#:sql-error-database-message
-
;; CLSQL Extensions
#:sql-condition
#:sql-error
#:sql-warning
#:sql-database-warning
-
- ;;FDDL
- #:create-table ; table xx
- #:drop-table ; table xx
- #:list-tables ; table xx
- #:table-exists-p ; table xx
- #:list-attributes ; table xx
- #:attribute-type ; table xx
- #:list-attribute-types ; table xx
- #:*cache-table-queries-default* ; table xx
- #:create-view ; table xx
- #:drop-view ; table xx
- #:create-index ; table xx
- #:drop-index ; table xx
- #:truncate-database
- ;;OODDL
- #:standard-db-object ; objects xx
- #:def-view-class ; objects xx
- #:create-view-from-class ; objects xx
- #:drop-view-from-class ; objects xx
- ;;OODML
- #:instance-refreshed ; objects xx
- #:update-objects-joins ; objects xx
- #:*default-update-objects-max-len* ; objects xx
- #:update-slot-from-record ; objects xx
- #:update-instance-from-records ; objects xx
- #:update-records-from-instance ; objects xx
- #:update-record-from-slot ; objects xx
- #:update-record-from-slots ; objects xx
- #:list-classes ; objects xx
- #:delete-instance-records ; objects xx
- ;;Symbolic SQL Syntax
- #:sql ; syntax xx
- #:sql-expression ; syntax xx
- #:sql-operation ; syntax xx
- #:sql-operator ; syntax xx
- #:disable-sql-reader-syntax ; syntax xx
- #:enable-sql-reader-syntax ; syntax xx
- #:locally-disable-sql-reader-syntax ; syntax xx
- #:locally-enable-sql-reader-syntax ; syntax xx
- #:restore-sql-reader-syntax-state ; syntax xx
-
- ;;FDDL
- #:list-views ; table xx
- #:view-exists-p ; table xx
- #:list-indexes ; table xx
- #:list-table-indexes ; table xx
- #:index-exists-p ; table xx
- #:create-sequence ; table xx
- #:drop-sequence ; table xx
- #:list-sequences ; table xx
- #:sequence-exists-p ; table xx
- #:sequence-next ; table xx
- #:sequence-last ; table xx
- #:set-sequence-position ; table xx
- ;;OODDL
- #:view-table ; metaclass x
- #:universal-time ; objects xx
+ #:*backend-warning-behavior*
+
+ ;; Connection/initialisation (base-classes.lisp, database.lisp,
+ ;; initialize.lisp)
+ #:*default-database-type*
+ #:*default-database*
+ #:*initialized-database-types*
+ #:initialize-database-type
+ #:connect
+ #:disconnect
+ #:*connect-if-exists*
+ #:connected-databases
+ #:database
+ #:database-name
+ #:reconnect
+ #:find-database
+ #:status
+ ;; CLSQL Extensions
+ #:with-database
+ #:with-default-database
+ #:disconnect-pooled
+ #:list-databases
+ #:create-database
+ #:destroy-database
+ #:probe-database
+ #:truncate-database
+
+ ;; I/O Recording (recording.lisp)
+ #:add-sql-stream
+ #:delete-sql-stream
+ #:list-sql-streams
+ #:sql-recording-p
+ #:sql-stream
+ #:start-sql-recording
+ #:stop-sql-recording
+ ;; CLSQL Extensions
+ #:record-sql-command
+ #:record-sql-result
+
+ ;; FDDL (fddl.lisp)
+ #:create-table
+ #:drop-table
+ #:list-tables
+ #:table-exists-p
+ #:list-attributes
+ #:attribute-type
+ #:list-attribute-types
+ #:*cache-table-queries-default*
+ #:create-view
+ #:drop-view
+ #:create-index
+ #:drop-index
+ ;; CLSQL Extensions
+ #:describe-table
+ #:list-views
+ #:view-exists-p
+ #:list-indexes
+ #:list-table-indexes
+ #:index-exists-p
+ #:create-sequence
+ #:drop-sequence
+ #:list-sequences
+ #:sequence-exists-p
+ #:sequence-next
+ #:sequence-last
+ #:set-sequence-position
+
+ ;; FDML (fdml.lisp)
+ #:select
+ #:cache-table-queries
+ #:*cache-table-queries-default*
+ #:delete-records
+ #:insert-records
+ #:update-records
+ #:execute-command
+ #:query
+ #:print-query
+ #:do-query
+ #:map-query
+ #:loop
+ ;; CLSQL Extensions
+ #:for-each-row
+
+ ;; Transaction handling (transaction.lisp)
+ #:with-transaction
+ #:commit
+ #:rollback
+ ;; CLSQL Extensions
+ #:commit-transaction
+ #:rollback-transaction
+ #:add-transaction-commit-hook
+ #:add-transaction-rollback-hook
+ #:start-transaction
+ #:in-transaction-p
+ #:database-start-transaction
+ #:database-abort-transaction
+ #:database-commit-transaction
+ #:transaction-level
+ #:transaction
+
+ ;; OODDL (ooddl.lisp)
+ #:standard-db-object
+ #:def-view-class
+ #:create-view-from-class
+ #:drop-view-from-class
+ #:list-classes
+ #:universal-time
+ ;; CLSQL Extensions
+ #:view-table
#:bigint
- ;;OODML
- #:*db-auto-sync* ; objects xx
-
- ;; conditions
- #:clsql-condition
- #:clsql-error
- #:clsql-simple-error
- #:clsql-simple-warning
+
+ ;; OODML (oodml.lisp)
+ #:instance-refreshed
+ #:update-objects-joins
+ #:*default-update-objects-max-len*
+ #:update-slot-from-record
+ #:update-instance-from-records
+ #:update-records-from-instance
+ #:update-record-from-slot
+ #:update-record-from-slots
+ #:delete-instance-records
+ ;; CLSQL Extensions
+ #:*db-auto-sync*
+
+ ;; Symbolic SQL Syntax (syntax.lisp)
+ #:sql
+ #:sql-expression
+ #:sql-operation
+ #:sql-operator
+ #:disable-sql-reader-syntax
+ #:enable-sql-reader-syntax
+ #:locally-disable-sql-reader-syntax
+ #:locally-enable-sql-reader-syntax
+ #:restore-sql-reader-syntax-state
- ;;-----------------------------------------------
- ;; Symbolic Sql Syntax
- ;;-----------------------------------------------
- #:sql-and-qualifier
- #:sql-escape
+ ;; SQL operations (operations.lisp)
#:sql-query
#:sql-object-query
#:sql-any
+ #:sql-some
#:sql-all
#:sql-not
#:sql-union
- #:sql-intersection
+ #:sql-intersect
#:sql-minus
- #:sql-group-by
- #:sql-having
+ #:sql-except
+ #:sql-order-by
#:sql-null
- #:sql-not-null
- #:sql-exists
#:sql-*
#:sql-+
#:sql-/
+ #:sql--
#:sql-like
- #:sql-uplike
#:sql-and
#:sql-or
#:sql-in
- #:sql-||
- #:sql-is
+ #:sql-concat
+ #:sql-substr
#:sql-=
- #:sql-==
#:sql-<
- #:sql->
- #:sql->=
- #:sql-<=
- #:sql-count
- #:sql-max
- #:sql-min
- #:sql-avg
- #:sql-sum
- #:sql-view-class
- #:sql_slot-value
-
-
-
- ;; time.lisp
- #:bad-component
- #:current-day
- #:current-month
- #:current-year
- #:day-duration
- #:db-timestring
- #:decode-duration
- #:decode-time
- #:duration
- #:duration+
- #:duration<
- #:duration<=
- #:duration=
- #:duration>
- #:duration>=
- #:duration-day
- #:duration-hour
- #:duration-minute
- #:duration-month
- #:duration-second
- #:duration-year
- #:duration-reduce
- #:duration-timestring
- #:extract-roman
- #:format-duration
- #:format-time
- #:get-time
- #:utime->time
- #:interval-clear
- #:interval-contained
- #:interval-data
- #:interval-edit
- #:interval-end
- #:interval-match
- #:interval-push
- #:interval-relation
- #:interval-start
- #:interval-type
- #:make-duration
- #:make-interval
- #:make-time
- #:merged-time
- #:midnight
- #:month-name
- #:parse-date-time
- #:parse-timestring
- #:parse-yearstring
- #:print-date
- #:roll
- #:roll-to
- #:time
- #:time+
- #:time-
- #:time-by-adding-duration
- #:time-compare
- #:time-difference
- #:time-dow
- #:time-element
- #:time-max
- #:time-min
- #:time-mjd
- #:time-msec
- #:time-p
- #:time-sec
- #:time-well-formed
- #:time-ymd
- #:time<
- #:time<=
- #:time=
- #:time>
- #:time>=
- #:timezone
- #:universal-time
- #:wall-time
- #:wall-timestring
- #:week-containing
- #:gregorian-to-mjd
- #:mjd-to-gregorian
-
- ;; recording.lisp -- SQL I/O Recording
- #:record-sql-command
- #:record-sql-result
- #:add-sql-stream ; recording xx
- #:delete-sql-stream ; recording xx
- #:list-sql-streams ; recording xx
- #:sql-recording-p ; recording xx
- #:sql-stream ; recording xx
- #:start-sql-recording ; recording xx
- #:stop-sql-recording ; recording xx
+ #:sql->
+ #:sql->=
+ #:sql-<=
+ #:sql-<>
+ #:sql-count
+ #:sql-max
+ #:sql-min
+ #:sql-avg
+ #:sql-sum
+ #:sql-function
+ #:sql-between
+ #:sql-distinct
+ #:sql-nvl
+ #:sql-slot-value
+ ;; CLSQL Extensions
+ #:sql-limit
+ #:sql-group-by
+ #:sql-having
+ #:sql-not-null
+ #:sql-exists
+ #:sql-uplike
+ #:sql-is
+ #:sql-==
+ #:sql-the
+ #:sql-coalesce
+ #:sql-view-class
- ;; database.lisp -- Connection
- #:*default-database-type* ; clsql-base xx
- #:*default-database* ; classes xx
- #:*initialized-database-types*
- #:initialize-database-type
- #:connect ; database xx
- #:disconnect ; database xx
- #:*connect-if-exists* ; database xx
- #:connected-databases ; database xx
- #:database ; database xx
- #:database-name ; database xx
- #:reconnect ; database
- #:find-database ; database xx
- #:status ; database xx
- #:with-database
- #:with-default-database
- #:disconnect-pooled
- #:create-database
- #:destroy-database
- #:probe-database
- #:list-databases
-
- #:describe-table
- #:*backend-warning-behavior*
-
- ;; Transactions
- #:with-transaction
- #:commit-transaction
- #:rollback-transaction
- #:add-transaction-commit-hook
- #:add-transaction-rollback-hook
- #:commit ; transact xx
- #:rollback ; transact xx
- #:with-transaction ; transact xx .
- #:start-transaction ; transact xx
- #:in-transaction-p ; transact xx
- #:database-start-transaction
- #:database-abort-transaction
- #:database-commit-transaction
- #:transaction-level
- #:transaction
- ))
- (:documentation "This is the INTERNAL SQL-Interface package of CLSQL."))
+ ;; Time handling (time.lisp)
+ #:bad-component
+ #:current-day
+ #:current-month
+ #:current-year
+ #:day-duration
+ #:db-timestring
+ #:decode-duration
+ #:decode-time
+ #:duration
+ #:duration+
+ #:duration<
+ #:duration<=
+ #:duration=
+ #:duration>
+ #:duration>=
+ #:duration-day
+ #:duration-hour
+ #:duration-minute
+ #:duration-month
+ #:duration-second
+ #:duration-year
+ #:duration-reduce
+ #:duration-timestring
+ #:extract-roman
+ #:format-duration
+ #:format-time
+ #:get-time
+ #:utime->time
+ #:interval-clear
+ #:interval-contained
+ #:interval-data
+ #:interval-edit
+ #:interval-end
+ #:interval-match
+ #:interval-push
+ #:interval-relation
+ #:interval-start
+ #:interval-type
+ #:make-duration
+ #:make-interval
+ #:make-time
+ #:merged-time
+ #:midnight
+ #:month-name
+ #:parse-date-time
+ #:parse-timestring
+ #:parse-yearstring
+ #:print-date
+ #:roll
+ #:roll-to
+ #:time
+ #:time+
+ #:time-
+ #:time-by-adding-duration
+ #:time-compare
+ #:time-difference
+ #:time-dow
+ #:time-element
+ #:time-max
+ #:time-min
+ #:time-mjd
+ #:time-msec
+ #:time-p
+ #:time-sec
+ #:time-well-formed
+ #:time-ymd
+ #:time<
+ #:time<=
+ #:time=
+ #:time>
+ #:time>=
+ #:timezone
+ #:universal-time
+ #:wall-time
+ #:wall-timestring
+ #:week-containing
+ #:gregorian-to-mjd
+ #:mjd-to-gregorian
+ ))
+ (:documentation "This is the INTERNAL SQL-Interface package of CLSQL."))
(defpackage #:clsql
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;;
-;;;; $Id$
-;;;;
-;;;; The CLSQL Functional Data Manipulation Language (FDML).
-;;;;
-;;;; This file is part of CLSQL.
-;;;;
-;;;; CLSQL users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(in-package #:clsql-sys)
-
-;;; Basic operations on databases
-
-(defmethod database-query-result-set ((expr %sql-expression) database
- &key full-set result-types)
- (database-query-result-set (sql-output expr database) database
- :full-set full-set :result-types result-types))
-
-(defmethod execute-command ((expr %sql-expression)
- &key (database *default-database*))
- (execute-command (sql-output expr database) :database database)
- (values))
-
-
-(defmethod query ((expr %sql-expression) &key (database *default-database*)
- (result-types :auto) (flatp nil) (field-names t))
- (query (sql-output expr database) :database database :flatp flatp
- :result-types result-types :field-names field-names))
-
-(defmethod query ((expr sql-object-query) &key (database *default-database*)
- (result-types :auto) (flatp nil) (field-names t))
- (declare (ignore result-types field-names))
- (apply #'select (append (slot-value expr 'objects)
- (slot-value expr 'exp)
- (when (slot-value expr 'refresh)
- (list :refresh (sql-output expr database)))
- (when (or flatp (slot-value expr 'flatp) )
- (list :flatp t))
- (list :database database))))
-
-(defun truncate-database (&key (database *default-database*))
- (unless (typep database 'database)
- (signal-no-database-error database))
- (unless (is-database-open database)
- (database-reconnect database))
- (when (eq :oracle (database-type database))
- (ignore-errors (execute-command "PURGE RECYCLEBIN" :database database)))
- (when (db-type-has-views? (database-underlying-type database))
- (dolist (view (list-views :database database))
- (drop-view view :database database)))
- (dolist (table (list-tables :database database))
- (drop-table table :database database))
- (dolist (index (list-indexes :database database))
- (drop-index index :database database))
- (dolist (seq (list-sequences :database database))
- (drop-sequence seq :database database))
- (when (eq :oracle (database-type database))
- (ignore-errors (execute-command "PURGE RECYCLEBIN" :database database))))
-
-(defun print-query (query-exp &key titles (formats t) (sizes t) (stream t)
- (database *default-database*))
- "Prints a tabular report of the results returned by the SQL
-query QUERY-EXP, which may be a symbolic SQL expression or a
-string, in DATABASE which defaults to *DEFAULT-DATABASE*. The
-report is printed onto STREAM which has a default value of t
-which means that *STANDARD-OUTPUT* is used. The TITLE argument,
-which defaults to nil, allows the specification of a list of
-strings to use as column titles in the tabular output. SIZES
-accepts a list of column sizes, one for each column selected by
-QUERY-EXP, to use in formatting the tabular report. The default
-value of t means that minimum sizes are computed. FORMATS is a
-list of format strings to be used for printing each column
-selected by QUERY-EXP. The default value of FORMATS is t meaning
-that ~A is used to format all columns or ~VA if column sizes are
-used."
- (flet ((compute-sizes (data)
- (mapcar #'(lambda (x)
- (apply #'max (mapcar #'(lambda (y)
- (if (null y) 3 (length y)))
- x)))
- (apply #'mapcar (cons #'list data))))
- (format-record (record control sizes)
- (format stream "~&~?" control
- (if (null sizes) record
- (mapcan #'(lambda (s f) (list s f)) sizes record)))))
- (let* ((query-exp (etypecase query-exp
- (string query-exp)
- (sql-query (sql-output query-exp database))))
- (data (query query-exp :database database :result-types nil
- :field-names nil))
- (sizes (if (or (null sizes) (listp sizes)) sizes
- (compute-sizes (if titles (cons titles data) data))))
- (formats (if (or (null formats) (not (listp formats)))
- (make-list (length (car data)) :initial-element
- (if (null sizes) "~A " "~VA "))
- formats))
- (control-string (format nil "~{~A~}" formats)))
- (when titles (format-record titles control-string sizes))
- (dolist (d data (values)) (format-record d control-string sizes)))))
-
-(defun insert-records (&key (into nil)
- (attributes nil)
- (values nil)
- (av-pairs nil)
- (query nil)
- (database *default-database*))
- "Inserts records into the table specified by INTO in DATABASE
-which defaults to *DEFAULT-DATABASE*. There are five ways of
-specifying the values inserted into each row. In the first VALUES
-contains a list of values to insert and ATTRIBUTES, AV-PAIRS and
-QUERY are nil. This can be used when values are supplied for all
-attributes in INTO. In the second, ATTRIBUTES is a list of column
-names, VALUES is a corresponding list of values and AV-PAIRS and
-QUERY are nil. In the third, ATTRIBUTES, VALUES and QUERY are nil
-and AV-PAIRS is an alist of (attribute value) pairs. In the
-fourth, VALUES, AV-PAIRS and ATTRIBUTES are nil and QUERY is a
-symbolic SQL query expression in which the selected columns also
-exist in INTO. In the fifth method, VALUES and AV-PAIRS are nil
-and ATTRIBUTES is a list of column names and QUERY is a symbolic
-SQL query expression which returns values for the specified
-columns."
- (let ((stmt (make-sql-insert :into into :attrs attributes
- :vals values :av-pairs av-pairs
- :subquery query)))
- (execute-command stmt :database database)))
-
-(defun make-sql-insert (&key (into nil)
- (attrs nil)
- (vals nil)
- (av-pairs nil)
- (subquery nil))
- (unless into
- (error 'sql-user-error :message ":into keyword not supplied"))
- (let ((insert (make-instance 'sql-insert :into into)))
- (with-slots (attributes values query)
- insert
- (cond ((and vals (not attrs) (not query) (not av-pairs))
- (setf values vals))
- ((and vals attrs (not subquery) (not av-pairs))
- (setf attributes attrs)
- (setf values vals))
- ((and av-pairs (not vals) (not attrs) (not subquery))
- (setf attributes (mapcar #'car av-pairs))
- (setf values (mapcar #'cadr av-pairs)))
- ((and subquery (not vals) (not attrs) (not av-pairs))
- (setf query subquery))
- ((and subquery attrs (not vals) (not av-pairs))
- (setf attributes attrs)
- (setf query subquery))
- (t
- (error 'sql-user-error
- :message "bad or ambiguous keyword combination.")))
- insert)))
-
-(defun delete-records (&key (from nil)
- (where nil)
- (database *default-database*))
- "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)))
- (execute-command stmt :database database)))
-
-(defun update-records (table &key (attributes nil)
- (values nil)
- (av-pairs nil)
- (where nil)
- (database *default-database*))
- "Updates the attribute values of existing records satsifying
-the SQL expression WHERE in the table specified by TABLE in
-DATABASE which defaults to *DEFAULT-DATABASE*. There are three
-ways of specifying the values to update for each row. In the
-first, VALUES contains a list of values to use in the update and
-ATTRIBUTES, AV-PAIRS and QUERY are nil. This can be used when
-values are supplied for all attributes in TABLE. In the second,
-ATTRIBUTES is a list of column names, VALUES is a corresponding
-list of values and AV-PAIRS and QUERY are nil. In the third,
-ATTRIBUTES, VALUES and QUERY are nil and AV-PAIRS is an alist
-of (attribute value) pairs."
- (when av-pairs
- (setf attributes (mapcar #'car av-pairs)
- values (mapcar #'cadr av-pairs)))
- (let ((stmt (make-instance 'sql-update :table table
- :attributes attributes
- :values values
- :where where)))
- (execute-command stmt :database database)))
-
-
-;; iteration
-
-;; output-sql
-
-(defmethod database-output-sql ((str string) database)
- (declare (ignore database)
- (optimize (speed 3) (safety 1) #+cmu (extensions:inhibit-warnings 3))
- (type (simple-array * (*)) str))
- (let ((len (length str)))
- (declare (type fixnum len))
- (cond ((= len 0)
- +empty-string+)
- ((and (null (position #\' str))
- (null (position #\\ str)))
- (concatenate 'string "'" str "'"))
- (t
- (let ((buf (make-string (+ (* len 2) 2) :initial-element #\')))
- (do* ((i 0 (incf i))
- (j 1 (incf j)))
- ((= i len) (subseq buf 0 (1+ j)))
- (declare (type integer i j))
- (let ((char (aref str i)))
- (cond ((eql char #\')
- (setf (aref buf j) #\\)
- (incf j)
- (setf (aref buf j) #\'))
- ((eql char #\\)
- (setf (aref buf j) #\\)
- (incf j)
- (setf (aref buf j) #\\))
- (t
- (setf (aref buf j) char))))))))))
-
-(let ((keyword-package (symbol-package :foo)))
- (defmethod database-output-sql ((sym symbol) database)
- (convert-to-db-default-case
- (if (equal (symbol-package sym) keyword-package)
- (concatenate 'string "'" (string sym) "'")
- (symbol-name sym))
- database)))
-
-(defmethod database-output-sql ((tee (eql t)) database)
- (declare (ignore database))
- "'Y'")
-
-(defmethod database-output-sql ((num number) database)
- (declare (ignore database))
- (princ-to-string num))
-
-(defmethod database-output-sql ((arg list) database)
- (if (null arg)
- "NULL"
- (format nil "(~{~A~^,~})" (mapcar #'(lambda (val)
- (sql-output val database))
- arg))))
-
-(defmethod database-output-sql ((arg vector) database)
- (format nil "~{~A~^,~}" (map 'list #'(lambda (val)
- (sql-output val database))
- arg)))
-
-(defmethod database-output-sql ((self wall-time) database)
- (declare (ignore database))
- (db-timestring self))
-
-(defmethod database-output-sql ((self duration) database)
- (declare (ignore database))
- (format nil "'~a'" (duration-timestring self)))
-
-(defmethod database-output-sql (thing database)
- (if (or (null thing)
- (eq 'null thing))
- "NULL"
- (error 'sql-user-error
- :message
- (format nil
- "No type conversion to SQL for ~A is defined for DB ~A."
- (type-of thing) (type-of database)))))
-
-
-(defmethod output-sql-hash-key ((arg vector) database)
- (list 'vector (map 'list (lambda (arg)
- (or (output-sql-hash-key arg database)
- (return-from output-sql-hash-key nil)))
- arg)))
-
-(defmethod output-sql (expr database)
- (write-string (database-output-sql expr database) *sql-stream*)
- (values))
-
-(defmethod output-sql ((expr list) database)
- (if (null expr)
- (write-string +null-string+ *sql-stream*)
- (progn
- (write-char #\( *sql-stream*)
- (do ((item expr (cdr item)))
- ((null (cdr item))
- (output-sql (car item) database))
- (output-sql (car item) database)
- (write-char #\, *sql-stream*))
- (write-char #\) *sql-stream*)))
- t)
-
-(defmethod describe-table ((table sql-create-table)
- &key (database *default-database*))
- (database-describe-table
- database
- (convert-to-db-default-case
- (symbol-name (slot-value table 'name)) database)))
-
-#+nil
-(defmethod add-storage-class ((self database) (class symbol) &key (sequence t))
- (let ((tablename (view-table (find-class class))))
- (unless (tablep tablename)
- (create-view-from-class class)
- (when sequence
- (create-sequence-from-class class)))))
-
-;;; Iteration
-
-
-(defmacro do-query (((&rest args) query-expression
- &key (database '*default-database*) (result-types :auto))
- &body body)
- "Repeatedly executes BODY within a binding of ARGS on the
-fields of each row selected by the SQL query QUERY-EXPRESSION,
-which may be a string or a symbolic SQL expression, in DATABASE
-which defaults to *DEFAULT-DATABASE*. The values returned by the
-execution of BODY are returned. RESULT-TYPES is a list of symbols
-which specifies the lisp type for each field returned by
-QUERY-EXPRESSION. If RESULT-TYPES is nil all results are returned
-as strings whereas the default value of :auto means that the lisp
-types are automatically computed for each field."
- (let ((result-set (gensym "RESULT-SET-"))
- (qe (gensym "QUERY-EXPRESSION-"))
- (columns (gensym "COLUMNS-"))
- (row (gensym "ROW-"))
- (db (gensym "DB-")))
- `(let ((,qe ,query-expression))
- (typecase ,qe
- (sql-object-query
- (dolist (,row (query ,qe))
- (destructuring-bind ,args
- ,row
- ,@body)))
- (t
- ;; Functional query
- (let ((,db ,database))
- (multiple-value-bind (,result-set ,columns)
- (database-query-result-set ,qe ,db
- :full-set nil
- :result-types ,result-types)
- (when ,result-set
- (unwind-protect
- (do ((,row (make-list ,columns)))
- ((not (database-store-next-row ,result-set ,db ,row))
- nil)
- (destructuring-bind ,args ,row
- ,@body))
- (database-dump-result-set ,result-set ,db))))))))))
-
-(defun map-query (output-type-spec function query-expression
- &key (database *default-database*)
- (result-types :auto))
- "Map the function FUNCTION over the attribute values of each
-row selected by the SQL query QUERY-EXPRESSION, which may be a
-string or a symbolic SQL expression, in DATABASE which defaults
-to *DEFAULT-DATABASE*. The results of the function are collected
-as specified in OUTPUT-TYPE-SPEC and returned like in
-MAP. RESULT-TYPES is a list of symbols which specifies the lisp
-type for each field returned by QUERY-EXPRESSION. If RESULT-TYPES
-is nil all results are returned as strings whereas the default
-value of :auto means that the lisp types are automatically
-computed for each field."
- (typecase query-expression
- (sql-object-query
- (map output-type-spec #'(lambda (x) (apply function x))
- (query query-expression)))
- (t
- ;; Functional query
- (macrolet ((type-specifier-atom (type)
- `(if (atom ,type) ,type (car ,type))))
- (case (type-specifier-atom output-type-spec)
- ((nil)
- (map-query-for-effect function query-expression database
- result-types))
- (list
- (map-query-to-list function query-expression database result-types))
- ((simple-vector simple-string vector string array simple-array
- bit-vector simple-bit-vector base-string
- simple-base-string)
- (map-query-to-simple output-type-spec function query-expression
- database result-types))
- (t
- (funcall #'map-query
- (cmucl-compat:result-type-or-lose output-type-spec t)
- function query-expression :database database
- :result-types result-types)))))))
-
-(defun map-query-for-effect (function query-expression database result-types)
- (multiple-value-bind (result-set columns)
- (database-query-result-set query-expression database :full-set nil
- :result-types result-types)
- (let ((flatp (and (= columns 1)
- (typecase query-expression
- (string t)
- (sql-query
- (slot-value query-expression 'flatp))))))
- (when result-set
- (unwind-protect
- (do ((row (make-list columns)))
- ((not (database-store-next-row result-set database row))
- nil)
- (if flatp
- (apply function row)
- (funcall function row)))
- (database-dump-result-set result-set database))))))
-
-(defun map-query-to-list (function query-expression database result-types)
- (multiple-value-bind (result-set columns)
- (database-query-result-set query-expression database :full-set nil
- :result-types result-types)
- (let ((flatp (and (= columns 1)
- (typecase query-expression
- (string t)
- (sql-query
- (slot-value query-expression 'flatp))))))
- (when result-set
- (unwind-protect
- (let ((result (list nil)))
- (do ((row (make-list columns))
- (current-cons result (cdr current-cons)))
- ((not (database-store-next-row result-set database row))
- (cdr result))
- (rplacd current-cons
- (list (if flatp
- (apply function row)
- (funcall function (copy-list row)))))))
- (database-dump-result-set result-set database))))))
-
-(defun map-query-to-simple (output-type-spec function query-expression database result-types)
- (multiple-value-bind (result-set columns rows)
- (database-query-result-set query-expression database :full-set t
- :result-types result-types)
- (let ((flatp (and (= columns 1)
- (typecase query-expression
- (string t)
- (sql-query
- (slot-value query-expression 'flatp))))))
- (when result-set
- (unwind-protect
- (if rows
- ;; We know the row count in advance, so we allocate once
- (do ((result
- (cmucl-compat:make-sequence-of-type output-type-spec rows))
- (row (make-list columns))
- (index 0 (1+ index)))
- ((not (database-store-next-row result-set database row))
- result)
- (declare (fixnum index))
- (setf (aref result index)
- (if flatp
- (apply function row)
- (funcall function (copy-list row)))))
- ;; Database can't report row count in advance, so we have
- ;; to grow and shrink our vector dynamically
- (do ((result
- (cmucl-compat:make-sequence-of-type output-type-spec 100))
- (allocated-length 100)
- (row (make-list columns))
- (index 0 (1+ index)))
- ((not (database-store-next-row result-set database row))
- (cmucl-compat:shrink-vector result index))
- (declare (fixnum allocated-length index))
- (when (>= index allocated-length)
- (setq allocated-length (* allocated-length 2)
- result (adjust-array result allocated-length)))
- (setf (aref result index)
- (if flatp
- (apply function row)
- (funcall function (copy-list row))))))
- (database-dump-result-set result-set database))))))
-
-;;; Row processing macro from CLSQL
-
-(defmacro for-each-row (((&rest fields) &key from order-by where distinct limit) &body body)
- (let ((d (gensym "DISTINCT-"))
- (bind-fields (loop for f in fields collect (car f)))
- (w (gensym "WHERE-"))
- (o (gensym "ORDER-BY-"))
- (frm (gensym "FROM-"))
- (l (gensym "LIMIT-"))
- (q (gensym "QUERY-")))
- `(let ((,frm ,from)
- (,w ,where)
- (,d ,distinct)
- (,l ,limit)
- (,o ,order-by))
- (let ((,q (query-string ',fields ,frm ,w ,d ,o ,l)))
- (loop for tuple in (query ,q)
- collect (destructuring-bind ,bind-fields tuple
- ,@body))))))
-
-(defun query-string (fields from where distinct order-by limit)
- (concatenate
- 'string
- (format nil "select ~A~{~A~^,~} from ~{~A~^ and ~}"
- (if distinct "distinct " "") (field-names fields)
- (from-names from))
- (if where (format nil " where ~{~A~^ ~}"
- (where-strings where)) "")
- (if order-by (format nil " order by ~{~A~^, ~}"
- (order-by-strings order-by)))
- (if limit (format nil " limit ~D" limit) "")))
-
-(defun lisp->sql-name (field)
- (typecase field
- (string field)
- (symbol (string-upcase (symbol-name field)))
- (cons (cadr field))
- (t (format nil "~A" field))))
-
-(defun field-names (field-forms)
- "Return a list of field name strings from a fields form"
- (loop for field-form in field-forms
- collect
- (lisp->sql-name
- (if (cadr field-form)
- (cadr field-form)
- (car field-form)))))
-
-(defun from-names (from)
- "Return a list of field name strings from a fields form"
- (loop for table in (if (atom from) (list from) from)
- collect (lisp->sql-name table)))
-
-
-(defun where-strings (where)
- (loop for w in (if (atom (car where)) (list where) where)
- collect
- (if (consp w)
- (format nil "~A ~A ~A" (second w) (first w) (third w))
- (format nil "~A" w))))
-
-(defun order-by-strings (order-by)
- (loop for o in order-by
- collect
- (if (atom o)
- (lisp->sql-name o)
- (format nil "~A ~A" (lisp->sql-name (car o))
- (lisp->sql-name (cadr o))))))
-
-
-
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;;
-;;;; $Id$
-;;;;
-;;;; The CLSQL Functional Data Definition Language (FDDL)
-;;;; including functions for schema manipulation. Currently supported
-;;;; SQL objects include tables, views, indexes, attributes and
-;;;; sequences.
-;;;;
-;;;; This file is part of CLSQL.
-;;;;
-;;;; CLSQL users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(in-package #:clsql-sys)
-
-
-;; Utilities
-
-(defun database-identifier (name database)
- (sql-escape (etypecase name
- ;; honor case of strings
- (string name
- #+nil (convert-to-db-default-case name database))
- (sql-ident (sql-output name database))
- (symbol (sql-output name database)))))
-
-
-;; Tables
-
-(defun create-table (name description &key (database *default-database*)
- (constraints nil) (transactions t))
- "Creates a table called NAME, which may be a string, symbol or
-SQL table identifier, in DATABASE which defaults to
-*DEFAULT-DATABASE*. DESCRIPTION is a list whose elements are
-lists containing the attribute names, types, and other
-constraints such as not-null or primary-key for each column in
-the table. CONSTRAINTS is a string representing an SQL table
-constraint expression or a list of such strings. With MySQL
-databases, if TRANSACTIONS is t an InnoDB table is created which
-supports transactions."
- (let* ((table-name (etypecase name
- (symbol (sql-expression :attribute name))
- (string (sql-expression :attribute name))
- (sql-ident name)))
- (stmt (make-instance 'sql-create-table
- :name table-name
- :columns description
- :modifiers constraints
- :transactions transactions)))
- (execute-command stmt :database database)))
-
-(defun drop-table (name &key (if-does-not-exist :error)
- (database *default-database*))
- "Drops the table called NAME from DATABASE which defaults to
-*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)
- (return-from drop-table nil)))
- (:error
- t))
-
- ;; Fixme: move to clsql-oracle
- (let ((expr (concatenate 'string "DROP TABLE " table-name)))
- (when (and (find-package 'clsql-oracle)
- (eq :oracle (database-type database))
- (eql 10 (slot-value database
- (intern (symbol-name '#:major-server-version)
- (symbol-name '#:clsql-oracle)))))
- (setq expr (concatenate 'string expr " PURGE")))
-
- (execute-command expr :database database))))
-
-(defun list-tables (&key (owner nil) (database *default-database*))
- "Returns a list of strings representing table names in DATABASE
-which defaults to *DEFAULT-DATABASE*. OWNER is nil by default
-which means that only tables owned by users are listed. If OWNER
-is a string denoting a user name, only tables owned by OWNER are
-listed. If OWNER is :all then all tables are listed."
- (database-list-tables database :owner owner))
-
-(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
-which means that only tables owned by users are examined. If
-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))
-
-
-;; Views
-
-(defun create-view (name &key as column-list (with-check-option nil)
- (database *default-database*))
- "Creates a view called NAME in DATABASE which defaults to
-*DEFAULT-DATABASE*. The view is created using the query AS and
-the columns of the view may be specified using the COLUMN-LIST
-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)))
- (stmt (make-instance 'sql-create-view
- :name view-name
- :column-list column-list
- :query as
- :with-check-option with-check-option)))
- (execute-command stmt :database database)))
-
-(defun drop-view (name &key (if-does-not-exist :error)
- (database *default-database*))
- "Drops the view called NAME from DATABASE which defaults to
-*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)
- (return-from drop-view)))
- (:error
- t))
- (let ((expr (concatenate 'string "DROP VIEW " view-name)))
- (execute-command expr :database database))))
-
-(defun list-views (&key (owner nil) (database *default-database*))
- "Returns a list of strings representing view names in DATABASE
-which defaults to *DEFAULT-DATABASE*. OWNER is nil by default
-which means that only views owned by users are listed. If OWNER
-is a string denoting a user name, only views owned by OWNER are
-listed. If OWNER is :all then all views are listed."
- (database-list-views database :owner owner))
-
-(defun view-exists-p (name &key (owner nil) (database *default-database*))
- "Tests for the existence of an SQL view called NAME in DATABASE
-which defaults to *DEFAULT-DATABASE*. OWNER is nil by default
-which means that only views owned by users are examined. If OWNER
-is a string denoting a user name, only views owned by OWNER are
-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)
- t))
-
-
-;; Indexes
-
-(defun create-index (name &key on (unique nil) attributes
- (database *default-database*))
- "Creates an index called NAME on the table specified by ON in
-DATABASE which default to *DEFAULT-DATABASE*. The table
-attributes to use in constructing the index NAME are specified by
-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)))
- (stmt (format nil "CREATE ~A INDEX ~A ON ~A (~{~A~^, ~})"
- (if unique "UNIQUE" "")
- index-name table-name attributes)))
- (execute-command stmt :database database)))
-
-(defun drop-index (name &key (if-does-not-exist :error)
- (on nil)
- (database *default-database*))
- "Drops the index called NAME in DATABASE which defaults to
-*DEFAULT-DATABASE*. If the index does not exist and
-IF-DOES-NOT-EXIST is :ignore then DROP-INDEX returns nil whereas
-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))
- (unless (db-type-use-column-on-drop-index?
- (database-underlying-type database))
- (setq on nil))
- (execute-command (format nil "DROP INDEX ~A~A" index-name
- (if (null on) ""
- (concatenate 'string " ON "
- (database-identifier on database))))
- :database database)))
-
-(defun list-indexes (&key (owner nil) (database *default-database*))
- "Returns a list of strings representing index names in DATABASE
-which defaults to *DEFAULT-DATABASE*. OWNER is nil by default
-which means that only indexes owned by users are listed. If OWNER
-is a string denoting a user name, only indexes owned by OWNER are
-listed. If OWNER is :all then all indexes are listed."
- (database-list-indexes database :owner owner))
-
-(defun list-table-indexes (table &key (owner nil)
- (database *default-database*))
- "Returns a list of strings representing index names on the
-table specified by TABLE in DATABASE which defaults to
-*DEFAULT-DATABASE*. OWNER is nil by default which means that only
-indexes owned by users are listed. If OWNER is a string denoting
-a user name, only indexes owned by OWNER are listed. If OWNER
-is :all then all indexes are listed."
- (database-list-table-indexes (database-identifier table database)
- database :owner owner))
-
-(defun index-exists-p (name &key (owner nil) (database *default-database*))
- "Tests for the existence of an SQL index called NAME in DATABASE
-which defaults to *DEFAULT-DATABASE*. OWNER is nil by default
-which means that only indexes owned by users are examined. If
-OWNER is a string denoting a user name, only indexes owned by
-OWNER are examined. If OWNER is :all then all indexes are
-examined."
- (when (member (database-identifier name database)
- (list-indexes :owner owner :database database)
- :test #'string-equal)
- t))
-
-;; Attributes
-
-(defvar *cache-table-queries-default* nil
- "Specifies the default behaivour for caching of attribute
- types. Meaningful values are t, nil and :flush as described for
- the action argument to CACHE-TABLE-QUERIES.")
-
-(defun cache-table-queries (table &key (action nil) (database *default-database*))
- "Controls the caching of attribute type information on the
-table specified by TABLE in DATABASE which defaults to
-*DEFAULT-DATABASE*. ACTION specifies the caching behaviour to
-adopt. If its value is t then attribute type information is
-cached whereas if its value is nil then attribute type
-information is not cached. If ACTION is :flush then all existing
-type information in the cache for TABLE is removed, but caching
-is still enabled. TABLE may be a string representing a table for
-which the caching action is to be taken while the caching action
-is applied to all tables if TABLE is t. Alternativly, when TABLE
-is :default, the default caching action specified by
-*CACHE-TABLE-QUERIES-DEFAULT* is applied to all table for which a
-caching action has not been explicitly set."
- (with-slots (attribute-cache) database
- (cond
- ((stringp table)
- (multiple-value-bind (val found) (gethash table attribute-cache)
- (cond
- ((and found (eq action :flush))
- (setf (gethash table attribute-cache) (list t nil)))
- ((and found (eq action t))
- (setf (gethash table attribute-cache) (list t (second val))))
- ((and found (null action))
- (setf (gethash table attribute-cache) (list nil nil)))
- ((not found)
- (setf (gethash table attribute-cache) (list action nil))))))
- ((eq table t)
- (maphash (lambda (k v)
- (cond
- ((eq action :flush)
- (setf (gethash k attribute-cache) (list t nil)))
- ((null action)
- (setf (gethash k attribute-cache) (list nil nil)))
- ((eq t action)
- (setf (gethash k attribute-cache) (list t (second v))))))
- attribute-cache))
- ((eq table :default)
- (maphash (lambda (k v)
- (when (eq (first v) :unspecified)
- (cond
- ((eq action :flush)
- (setf (gethash k attribute-cache) (list t nil)))
- ((null action)
- (setf (gethash k attribute-cache) (list nil nil)))
- ((eq t action)
- (setf (gethash k attribute-cache) (list t (second v)))))))
- attribute-cache))))
- (values))
-
-
-(defun list-attributes (name &key (owner nil) (database *default-database*))
- "Returns a list of strings representing the attributes of table
-NAME in DATABASE which defaults to *DEFAULT-DATABASE*. OWNER is
-nil by default which means that only attributes owned by users
-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
- :owner owner))
-
-(defun attribute-type (attribute table &key (owner nil)
- (database *default-database*))
- "Returns a string representing the field type of the supplied
-attribute ATTRIBUTE in the table specified by TABLE in DATABASE
-which defaults to *DEFAULT-DATABASE*. OWNER is nil by default
-which means that the attribute specified by ATTRIBUTE, if it
-exists, must be user owned else nil is returned. If OWNER is a
-string denoting a user name, the 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
- :owner owner))
-
-(defun list-attribute-types (table &key (owner nil)
- (database *default-database*))
- "Returns a list containing information about the SQL types of
-each of the attributes in the table specified by TABLE in
-DATABASE which has a default value of *DEFAULT-DATABASE*. OWNER
-is nil by default which means that only attributes owned by users
-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. The elements of the returned list are
-lists where the first element is the name of the attribute, the
-second element is its SQL type, the third is the type precision,
-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)))
- (multiple-value-bind (val found) (gethash table-ident attribute-cache)
- (if (and found (second val))
- (second val)
- (let ((types (mapcar #'(lambda (attribute)
- (cons attribute
- (multiple-value-list
- (database-attribute-type
- (database-identifier attribute
- database)
- table-ident
- database
- :owner owner))))
- (list-attributes table :database database
- :owner owner))))
- (cond
- ((and (not found) (eq t *cache-table-queries-default*))
- (setf (gethash table-ident attribute-cache)
- (list :unspecified types)))
- ((and found (eq t (first val))
- (setf (gethash table-ident attribute-cache)
- (list t types)))))
- types))))))
-
-
-;; Sequences
-
-(defun create-sequence (name &key (database *default-database*))
- "Creates a sequence called NAME in DATABASE which defaults to
-*DEFAULT-DATABASE*."
- (let ((sequence-name (database-identifier name database)))
- (database-create-sequence sequence-name database))
- (values))
-
-(defun drop-sequence (name &key (if-does-not-exist :error)
- (database *default-database*))
- "Drops the sequence called NAME from DATABASE which defaults to
-*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))
- (values))
-
-(defun list-sequences (&key (owner nil) (database *default-database*))
- "Returns a list of strings representing sequence names in
-DATABASE which defaults to *DEFAULT-DATABASE*. OWNER is nil by
-default which means that only sequences owned by users are
-listed. If OWNER is a string denoting a user name, only sequences
-owned by OWNER are listed. If OWNER is :all then all sequences
-are listed."
- (database-list-sequences database :owner owner))
-
-(defun sequence-exists-p (name &key (owner nil)
- (database *default-database*))
- "Tests for the existence of an SQL sequence called NAME in
-DATABASE which defaults to *DEFAULT-DATABASE*. OWNER is nil by
-default which means that only sequences owned by users are
-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))
-
-(defun sequence-next (name &key (database *default-database*))
- "Return the next value in the sequence called NAME in DATABASE
- which defaults to *DEFAULT-DATABASE*."
- (database-sequence-next (database-identifier name database) database))
-
-(defun set-sequence-position (name position &key (database *default-database*))
- "Explicitly set the the position of the sequence called NAME in
-DATABASE, which defaults to *DEFAULT-DATABSE*, to POSITION."
- (database-set-sequence-position (database-identifier name database)
- position database))
-
-(defun sequence-last (name &key (database *default-database*))
- "Return the last value of the sequence called NAME in DATABASE
- which defaults to *DEFAULT-DATABASE*."
- (database-sequence-last (database-identifier name database) database))
-
(when (zerop (decf (transaction-level database)))
(execute-command "COMMIT" :database database)
(map nil #'funcall (commit-hooks (transaction database))))
- (warn 'clsql-simple-warning
+ (warn 'sql-warning
:format-control "Cannot commit transaction against ~A because there is no transaction in progress."
:format-arguments (list database))))
(unwind-protect
(execute-command "ROLLBACK" :database database)
(map nil #'funcall (rollback-hooks (transaction database)))))
- (warn 'clsql-simple-warning
+ (warn 'sql-warning
:format-control "Cannot abort transaction against ~A because there is no transaction in progress."
:format-arguments (list database))))