From: Marcus Pearce Date: Mon, 24 May 2004 21:16:52 +0000 (+0000) Subject: r9457: Reworked CLSQL file structure. X-Git-Tag: v3.8.6~391 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=e622ee6f4bf2b9fe81af59d566e651c983a4833b r9457: Reworked CLSQL file structure. --- diff --git a/ChangeLog b/ChangeLog index b454968..1965c5b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,28 @@ +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 diff --git a/clsql.asd b/clsql.asd index c7b3d92..f9e8bff 100644 --- a/clsql.asd +++ b/clsql.asd @@ -36,35 +36,41 @@ oriented interface." :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 "" diff --git a/db-aodbc/aodbc-sql.lisp b/db-aodbc/aodbc-sql.lisp index 8a6ee00..7994892 100644 --- a/db-aodbc/aodbc-sql.lisp +++ b/db-aodbc/aodbc-sql.lisp @@ -57,7 +57,7 @@ (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 diff --git a/db-postgresql-socket/postgresql-socket-sql.lisp b/db-postgresql-socket/postgresql-socket-sql.lisp index ab4d710..46e82ce 100644 --- a/db-postgresql-socket/postgresql-socket-sql.lisp +++ b/db-postgresql-socket/postgresql-socket-sql.lisp @@ -182,7 +182,7 @@ doesn't depend on UFFI." (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)))))) diff --git a/db-sqlite/sqlite-sql.lisp b/db-sqlite/sqlite-sql.lisp index 3c6d31e..17e8ff8 100644 --- a/db-sqlite/sqlite-sql.lisp +++ b/db-sqlite/sqlite-sql.lisp @@ -62,7 +62,7 @@ (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)))) diff --git a/sql/base-classes.lisp b/sql/base-classes.lisp index 7ebbc5c..4e33010 100644 --- a/sql/base-classes.lisp +++ b/sql/base-classes.lisp @@ -51,4 +51,5 @@ are a list of ACTION specified for table and any cached value of list-attributes "") (database-state object)))) - +(setf (documentation 'database-name 'function) + "Returns the name of a database.") diff --git a/sql/basic-sql.lisp b/sql/basic-sql.lisp deleted file mode 100644 index ae42dd9..0000000 --- a/sql/basic-sql.lisp +++ /dev/null @@ -1,83 +0,0 @@ -;;;; -*- 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)) - diff --git a/sql/classes.lisp b/sql/classes.lisp deleted file mode 100644 index 80d735c..0000000 --- a/sql/classes.lisp +++ /dev/null @@ -1,873 +0,0 @@ -;;;; -*- 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 " ")))))))) - diff --git a/sql/database.lisp b/sql/database.lisp index d592181..f155732 100644 --- a/sql/database.lisp +++ b/sql/database.lisp @@ -14,10 +14,6 @@ (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 diff --git a/sql/expressions.lisp b/sql/expressions.lisp new file mode 100644 index 0000000..fb9f3f7 --- /dev/null +++ b/sql/expressions.lisp @@ -0,0 +1,873 @@ +;;;; -*- 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 " ")))))))) + diff --git a/sql/fddl.lisp b/sql/fddl.lisp new file mode 100644 index 0000000..608a114 --- /dev/null +++ b/sql/fddl.lisp @@ -0,0 +1,416 @@ +;;;; -*- 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)) + diff --git a/sql/fdml.lisp b/sql/fdml.lisp new file mode 100644 index 0000000..1593030 --- /dev/null +++ b/sql/fdml.lisp @@ -0,0 +1,585 @@ +;;;; -*- 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)) + + diff --git a/sql/generics.lisp b/sql/generics.lisp index f4b2848..d513bd3 100644 --- a/sql/generics.lisp +++ b/sql/generics.lisp @@ -18,6 +18,38 @@ (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 diff --git a/sql/objects.lisp b/sql/objects.lisp deleted file mode 100644 index 63cef6a..0000000 --- a/sql/objects.lisp +++ /dev/null @@ -1,1260 +0,0 @@ -;;;; -*- 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)) - diff --git a/sql/ooddl.lisp b/sql/ooddl.lisp new file mode 100644 index 0000000..d37470d --- /dev/null +++ b/sql/ooddl.lisp @@ -0,0 +1,209 @@ +;;;; -*- 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)) diff --git a/sql/oodml.lisp b/sql/oodml.lisp new file mode 100644 index 0000000..d44b90b --- /dev/null +++ b/sql/oodml.lisp @@ -0,0 +1,1067 @@ +;;;; -*- 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)) + diff --git a/sql/package.lisp b/sql/package.lisp index f196f5b..2a07e84 100644 --- a/sql/package.lisp +++ b/sql/package.lisp @@ -148,6 +148,9 @@ #: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 @@ -182,17 +185,6 @@ #: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 @@ -203,289 +195,294 @@ #: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 diff --git a/sql/sql.lisp b/sql/sql.lisp deleted file mode 100644 index e3e064a..0000000 --- a/sql/sql.lisp +++ /dev/null @@ -1,548 +0,0 @@ -;;;; -*- 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)))))) - - - diff --git a/sql/table.lisp b/sql/table.lisp deleted file mode 100644 index bc68a81..0000000 --- a/sql/table.lisp +++ /dev/null @@ -1,416 +0,0 @@ -;;;; -*- 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)) - diff --git a/sql/transaction.lisp b/sql/transaction.lisp index 6ea37b6..286839b 100644 --- a/sql/transaction.lisp +++ b/sql/transaction.lisp @@ -47,7 +47,7 @@ (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)))) @@ -57,7 +57,7 @@ (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))))