From dc107d34212597ed1272cfa21138d384e71b00d2 Mon Sep 17 00:00:00 2001 From: Russ Tyndall Date: Mon, 24 Aug 2009 17:14:09 -0400 Subject: [PATCH] Major rewrite of table/column name output escaping system wide. Centralized logic in database-identifier that returns database-identifier objects. These allow us to coerce to a canonical output name and have both its escaped and unescaped version available. Previously the logic for converting from various sql-expressions, symbols and strings into names that will be sent to the database, was done all over the place and with different logic in each location prev:5282676789105fe52990b29ec991209dcfa84aa6 6d643c3749b77b6e6207871f0cf40f135094f457 6bf69ed2c616ea75e5402bd95853adee5551743b --- db-mysql/mysql-sql.lisp | 37 +++-- db-postgresql-socket3/sql.lisp | 1 - sql/conditions.lisp | 8 + sql/expressions.lisp | 289 +++++++++++++++++++++++---------- sql/fddl.lisp | 127 +++++++-------- sql/fdml.lisp | 6 +- sql/generic-postgresql.lisp | 115 +++++++------ sql/generics.lisp | 21 ++- sql/metaclasses.lisp | 59 +++---- sql/ooddl.lisp | 37 +++-- sql/oodml.lisp | 45 +++-- sql/sequences.lisp | 23 +-- sql/syntax.lisp | 2 +- sql/utils.lisp | 17 ++ tests/datasets.lisp | 6 +- 15 files changed, 475 insertions(+), 318 deletions(-) diff --git a/db-mysql/mysql-sql.lisp b/db-mysql/mysql-sql.lisp index 503da2a..857bcd5 100644 --- a/db-mysql/mysql-sql.lisp +++ b/db-mysql/mysql-sql.lisp @@ -16,6 +16,10 @@ (defpackage #:clsql-mysql (:use #:common-lisp #:clsql-sys #:mysql #:clsql-uffi) (:export #:mysql-database) + (:import-from :clsql-sys + :escaped :unescaped :combine-database-identifiers + :escaped-database-identifier :unescaped-database-identifier :database-identifier + :%sequence-name-to-table :%table-name-to-sequence-name) (:documentation "This is the CLSQL interface to MySQL.")) (in-package #:clsql-mysql) @@ -391,7 +395,8 @@ (declare (ignore owner)) (do ((results nil) (rows (database-query - (format nil "SHOW INDEX FROM ~A" table) + (format nil "SHOW INDEX FROM ~A" (escaped-database-identifier + table database)) database nil nil) (cdr rows))) ((null rows) (nreverse results)) @@ -404,7 +409,8 @@ (declare (ignore owner)) (mapcar #'car (database-query - (format nil "SHOW COLUMNS FROM ~A" table) + (format nil "SHOW COLUMNS FROM ~A" (escaped-database-identifier + table database)) database nil nil))) (defmethod database-attribute-type (attribute (table string) @@ -413,7 +419,11 @@ (declare (ignore owner)) (let ((row (car (database-query (format nil - "SHOW COLUMNS FROM ~A LIKE '~A'" table attribute) + "SHOW COLUMNS FROM ~A LIKE '~A'" + (escaped-database-identifier + table database) + (unescaped-database-identifier + attribute database)) database nil nil)))) (let* ((raw-type (second row)) (null (third row)) @@ -429,17 +439,9 @@ ;;; Sequence functions -(defun %sequence-name-to-table (sequence-name) - (concatenate 'string "_CLSQL_SEQ_" (sql-escape sequence-name))) - -(defun %table-name-to-sequence-name (table-name) - (and (>= (length table-name) 11) - (string-equal (subseq table-name 0 11) "_CLSQL_SEQ_") - (subseq table-name 11))) - (defmethod database-create-sequence (sequence-name (database mysql-database)) - (let ((table-name (%sequence-name-to-table sequence-name))) + (let ((table-name (%sequence-name-to-table sequence-name database))) (database-execute-command (concatenate 'string "CREATE TABLE " table-name " (id int NOT NULL PRIMARY KEY AUTO_INCREMENT)") @@ -452,7 +454,8 @@ (defmethod database-drop-sequence (sequence-name (database mysql-database)) (database-execute-command - (concatenate 'string "DROP TABLE " (%sequence-name-to-table sequence-name)) + (concatenate 'string "DROP TABLE " + (%sequence-name-to-table sequence-name database)) database)) (defmethod database-list-sequences ((database mysql-database) @@ -460,14 +463,14 @@ (declare (ignore owner)) (mapcan #'(lambda (s) (let ((sn (%table-name-to-sequence-name (car s)))) - (and sn (list sn)))) + (and sn (list (car s) sn)))) (database-query "SHOW TABLES" database nil nil))) (defmethod database-set-sequence-position (sequence-name (position integer) (database mysql-database)) (database-execute-command - (format nil "UPDATE ~A SET id=~A" (%sequence-name-to-table sequence-name) + (format nil "UPDATE ~A SET id=~A" (%sequence-name-to-table sequence-name database) position) database) (mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database))) @@ -475,7 +478,7 @@ (defmethod database-sequence-next (sequence-name (database mysql-database)) (without-interrupts (database-execute-command - (concatenate 'string "UPDATE " (%sequence-name-to-table sequence-name) + (concatenate 'string "UPDATE " (%sequence-name-to-table sequence-name database) " SET id=LAST_INSERT_ID(id+1)") database) (mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database)))) @@ -484,7 +487,7 @@ (without-interrupts (caar (database-query (concatenate 'string "SELECT id from " - (%sequence-name-to-table sequence-name)) + (%sequence-name-to-table sequence-name database)) database :auto nil)))) (defmethod database-last-auto-increment-id ((database mysql-database) table column) diff --git a/db-postgresql-socket3/sql.lisp b/db-postgresql-socket3/sql.lisp index 1f27989..f8573a2 100644 --- a/db-postgresql-socket3/sql.lisp +++ b/db-postgresql-socket3/sql.lisp @@ -330,4 +330,3 @@ (defmethod read-sql-value (val (type (eql 'generalized-boolean)) (database postgresql-socket3-database) db-type) (declare (ignore database db-type)) val) - diff --git a/sql/conditions.lisp b/sql/conditions.lisp index 51c06ad..3ef9412 100644 --- a/sql/conditions.lisp +++ b/sql/conditions.lisp @@ -134,3 +134,11 @@ connection is no longer usable.")) "While accessing database ~A~% Warning: ~A~% has occurred." (sql-warning-database c) (sql-warning-message c))))) + +(define-condition database-too-strange (sql-user-error) + () + (:documentation "Used to signal cases where CLSQL is going to fail at + mapping your database correctly")) + +(defun signal-database-too-strange (message) + (error 'database-too-strange :message message)) diff --git a/sql/expressions.lisp b/sql/expressions.lisp index b808064..90b2620 100644 --- a/sql/expressions.lisp +++ b/sql/expressions.lisp @@ -20,6 +20,110 @@ (defvar *sql-stream* nil "stream which accumulates SQL output") +(defclass %database-identifier () + ((escaped :accessor escaped :initarg :escaped :initform nil) + (unescaped :accessor unescaped :initarg :unescaped :initform nil)) + (:documentation + "A database identifier represents a string/symbol ready to be spliced + into a sql string. It keeps references to both the escaped and + unescaped versions so that unescaped versions can be compared to the + results of list-tables/views/attributes etc. It also allows you to be + sure that an identifier is escaped only once. + + (escaped-database-identifiers *any-reasonable-object*) should be called to + produce a string that is safe to splice directly into sql strings. + + (unescaped-database-identifier *any-reasonable-object*) is generally what + you pass to it with the exception that symbols have been + clsql-sys:sql-escape which converts to a string and changes - to _ (so + that unescaped can be compared to the results of eg: list-tables) + ")) + +(defmethod escaped ((it null)) it) +(defmethod unescaped ((it null)) it) + +(defun database-identifier-equal (i1 i2 &optional (database clsql-sys:*default-database*)) + (setf i1 (database-identifier i1 database) + i2 (database-identifier i2 database)) + (flet ((cast (i) + (if (symbolp (unescaped i)) + (sql-escape (unescaped i)) + (unescaped i)))) + (or ;; check for an exact match + (equal (escaped-database-identifier i1) + (escaped-database-identifier i2)) + ;; check for an inexact match if we had symbols in the mix + (string-equal (cast i1) (cast i2))))) + +(defun delistify-dsd (list) + "Some MOPs, like openmcl 0.14.2, cons attribute values in a list." + (if (and (listp list) (null (cdr list))) + (car list) + list)) + +(defun special-char-p (s) + "Check if a string has any special characters" + (loop for char across s + thereis (find char '(#\space #\, #\. #\! #\@ #\# #\$ #\% #\' #\" + #\^ #\& #\* #\| #\( #\) #\- #\+ #\< #\> + #\{ #\})))) + +(defun %make-database-identifier (inp &optional database) + "We want to quote an identifier if it came to us as a string or if it has special characters + in it." + (labels ((%escape-identifier (inp &optional orig) + "Quote an identifier unless it is already quoted" + (cond + ;; already quoted + ((and (eql #\" (elt inp 0)) + (eql #\" (elt inp (- (length inp) 1)))) + (make-instance '%database-identifier :unescaped (or orig inp) :escaped inp)) + (T (make-instance + '%database-identifier :unescaped (or orig inp) :escaped + (concatenate + 'string "\"" (replace-all inp "\"" "\\\"") "\"")))))) + (typecase inp + (string (%escape-identifier inp)) + (%database-identifier inp) + (symbol + (let ((s (sql-escape inp))) + (if (and (not (eql '* inp)) (special-char-p s)) + (%escape-identifier (convert-to-db-default-case s database) inp) + (make-instance '%database-identifier :escaped s :unescaped inp))))))) + +(defun combine-database-identifiers (ids &optional (database clsql-sys:*default-database*) + &aux res all-sym? pkg) + "Create a new database identifier by combining parts in a reasonable way + " + (setf ids (mapcar #'database-identifier ids) + all-sym? (every (lambda (i) (symbolp (unescaped i))) ids) + pkg (when all-sym? (symbol-package (unescaped (first ids))))) + (labels ((cast ( i ) + (typecase i + (null nil) + (%database-identifier (cast (unescaped i))) + (symbol + (if all-sym? + (sql-escape i) + (convert-to-db-default-case (sql-escape i) database))) + (string i))) + (comb (i1 i2) + (setf i1 (cast i1) + i2 (cast i2)) + (if (and i1 i2) + (concatenate 'string (cast i1) "_" (cast i2)) + (or i1 i2)))) + (setf res (reduce #'comb ids)) + (database-identifier + (if all-sym? (intern res pkg) res) + database))) + +(defun escaped-database-identifier (name &optional database find-class-p) + (escaped (database-identifier name database find-class-p))) + +(defun unescaped-database-identifier (name &optional database find-class-p) + (unescaped (database-identifier name database find-class-p))) + (defun sql-output (sql-expr &optional (database *default-database*)) "Top-level call for generating SQL strings. Returns an SQL string appropriate for DATABASE which corresponds to the @@ -107,13 +211,12 @@ sql `(make-instance 'sql-ident :name ',name))) +(defmethod output-sql ((expr %database-identifier) database) + (write-string (escaped expr) *sql-stream*)) + (defmethod output-sql ((expr sql-ident) database) (with-slots (name) expr - (write-string - (etypecase name - (string name) - (symbol (symbol-name name))) - *sql-stream*)) + (write-string (escaped-database-identifier name database) *sql-stream*)) t) ;; For SQL Identifiers for attributes @@ -134,7 +237,10 @@ (defmethod collect-table-refs ((sql sql-ident-attribute)) (let ((qual (slot-value sql 'qualifier))) (when qual - (list (make-instance 'sql-ident-table :name qual))))) + ;; going to be used as a table, search classes + (list (make-instance + 'sql-ident-table + :name (database-identifier qual nil t)))))) (defmethod make-load-form ((sql sql-ident-attribute) &optional environment) (declare (ignore environment)) @@ -144,35 +250,6 @@ :qualifier ',qualifier :type ',type))) -(defmethod output-sql ((expr sql-ident-attribute) database) - (with-slots (qualifier name type) expr - (if (and (not qualifier) (not type)) - (etypecase name - (string - (write-string name *sql-stream*)) - (symbol - (write-string - (sql-escape (symbol-name name)) *sql-stream*))) - - ;;; KMR: The TYPE field is used by CommonSQL for type conversion -- it - ;;; should not be output in SQL statements - #+ignore - (format *sql-stream* "~@[~A.~]~A~@[ ~A~]" - (when qualifier - (sql-escape qualifier)) - (sql-escape name) - (when type - (symbol-name type))) - (format *sql-stream* "~@[~A.~]~A" - (when qualifier - (typecase qualifier - (string (format nil "~s" qualifier)) - (t (sql-escape qualifier)))) - (typecase name - (string (format nil "~s" (sql-escape name))) - (t (sql-escape name))))) - t)) - (defmethod output-sql-hash-key ((expr sql-ident-attribute) database) (with-slots (qualifier name type) expr @@ -192,27 +269,30 @@ sql `(make-instance 'sql-ident-table :name ',name :table-alias ',alias))) -(defun special-char-p (s) - "Check if a string has any special characters" - (loop for char across s - thereis (find char '(#\space #\, #\. #\! #\@ #\# #\$ #\% - #\^ #\& #\* #\| #\( #\) #\- #\+)))) - (defmethod output-sql ((expr sql-ident-table) database) (with-slots (name alias) expr (flet ((p (s) ;; the etypecase is in sql-escape too - (let ((sym? (symbolp s)) - (s (sql-escape s))) - (format *sql-stream* - (if (and sym? (not (special-char-p s))) - "~a" "~s") - s)))) + (write-string + (escaped-database-identifier s database) + *sql-stream*))) (p name) (when alias (princ #\space *sql-stream*) (p alias)))) t) +(defmethod output-sql ((expr sql-ident-attribute) database) +;;; KMR: The TYPE field is used by CommonSQL for type conversion -- it +;;; should not be output in SQL statements + (let ((*print-pretty* nil)) + (with-slots (qualifier name type) expr + (format *sql-stream* "~@[~a.~]~a" + (when qualifier + ;; check for classes + (escaped-database-identifier qualifier database T)) + (escaped-database-identifier name database)) + t))) + (defmethod output-sql-hash-key ((expr sql-ident-table) database) (with-slots (name alias) expr @@ -238,10 +318,7 @@ (dolist (exp (slot-value sql 'sub-expressions)) (let ((refs (collect-table-refs exp))) (if refs (setf tabs (append refs tabs))))) - (remove-duplicates tabs - :test (lambda (tab1 tab2) - (equal (slot-value tab1 'name) - (slot-value tab2 'name)))))) + (remove-duplicates tabs :test #'database-identifier-equal))) @@ -336,10 +413,7 @@ (dolist (exp (slot-value sql 'components)) (let ((refs (collect-table-refs exp))) (if refs (setf tabs (append refs tabs))))) - (remove-duplicates tabs - :test (lambda (tab1 tab2) - (equal (slot-value tab1 'name) - (slot-value tab2 'name))))) + (remove-duplicates tabs :test #'database-identifier-equal)) nil))) @@ -384,10 +458,7 @@ (dolist (exp (slot-value sql 'args)) (let ((refs (collect-table-refs exp))) (if refs (setf tabs (append refs tabs))))) - (remove-duplicates tabs - :test (lambda (tab1 tab2) - (equal (slot-value tab1 'name) - (slot-value tab2 'name)))))) + (remove-duplicates tabs :test #'database-identifier-equal))) (defvar *in-subselect* nil) (defmethod output-sql ((expr sql-function-exp) database) @@ -445,10 +516,7 @@ (dolist (exp (slot-value sql 'sub-expressions)) (let ((refs (collect-table-refs exp))) (if refs (setf tabs (append refs tabs))))) - (remove-duplicates tabs - :test (lambda (tab1 tab2) - (equal (slot-value tab1 'name) - (slot-value tab2 'name)))))) + (remove-duplicates tabs :test #'database-identifier-equal))) (defmethod output-sql ((expr sql-set-exp) database) (with-slots (operator sub-expressions) @@ -527,10 +595,9 @@ :initform nil))) (defmethod collect-table-refs ((sql sql-query)) - (remove-duplicates (collect-table-refs (slot-value sql 'where)) - :test (lambda (tab1 tab2) - (equal (slot-value tab1 'name) - (slot-value tab2 'name))))) + (remove-duplicates + (collect-table-refs (slot-value sql 'where)) + :test #'database-identifier-equal)) (defvar *select-arguments* '(:all :database :distinct :flatp :from :group-by :having :order-by @@ -602,24 +669,16 @@ uninclusive, and the args from that keyword to the end." (output-sql (apply #'vector selections) database)) (when from (write-string " FROM " *sql-stream*) - (labels ((ident-string-val (a) - (typecase a - (sql-ident - (or (ignore-errors (slot-value a 'alias)) - (ignore-errors (slot-value a 'name)))) - (string a))) - (ident-table-equal (a b) - ;; The things should be type compatable - (string-equal (ident-string-val a) - (ident-string-val b)))) - (typecase from - (list (output-sql (apply #'vector - (remove-duplicates from - :test #'ident-table-equal)) - database)) - (string (format *sql-stream* "~s" (sql-escape from))) - (t (let ((*in-subselect* t)) - (output-sql from database)))))) + (typecase from + (list (output-sql + (apply #'vector + (remove-duplicates from :test #'database-identifier-equal)) + database)) + (string (write-string + (escaped-database-identifier from database) + *sql-stream*)) + (t (let ((*in-subselect* t)) + (output-sql from database))))) (when inner-join (write-string " INNER JOIN " *sql-stream*) (output-sql inner-join database)) @@ -835,10 +894,7 @@ uninclusive, and the args from that keyword to the end." (with-slots (name columns modifiers transactions) stmt (write-string "CREATE TABLE " *sql-stream*) - (etypecase name - (string (format *sql-stream* "~s" (sql-escape name))) - (symbol (write-string (sql-escape name) *sql-stream*)) - (sql-ident (output-sql name database))) + (write-string (escaped-database-identifier name database) *sql-stream*) (write-string " (" *sql-stream*) (do ((column columns (cdr column))) ((null (cdr column)) @@ -1029,3 +1085,58 @@ uninclusive, and the args from that keyword to the end." (if (< 1 (length constraint)) (setq string (concatenate 'string string " ")))))))) +(defmethod database-identifier ( name &optional database find-class-p + &aux cls) + "A function that takes whatever you give it, recurively coerces it, + and returns a database-identifier. + + (escaped-database-identifiers *any-reasonable-object*) should be called to + produce a string that is safe to splice directly into sql strings. + + This function should NOT throw errors when database is nil + + find-class-p should be T if we want to search for classes + and check their use their view table. Should be used + on symbols we are sure indicate tables + + + ;; metaclasses has further typecases of this, so that it will + ;; load less painfully (try-recompiles) in SBCL + + " + (flet ((flatten-id (id) + "if we have multiple pieces that we need to represent as + db-id lets do that by rendering out the id, then creating + a new db-id with that string as escaped" + (let ((s (sql-output id database))) + (make-instance '%database-identifier :escaped s :unescaped s)))) + (etypecase name + (null nil) + (string (%make-database-identifier name database)) + (symbol + ;; if this is being used as a table, we should check + ;; for a class with this name and use the identifier specified + ;; on it + (if (and find-class-p (setf cls (find-standard-db-class name))) + (database-identifier cls) + (%make-database-identifier name database))) + (%database-identifier name) + ;; we know how to deref this without further escaping + (sql-ident-table + (with-slots ((inner-name name) alias) name + (if alias + (flatten-id name) + (database-identifier inner-name)))) + ;; if this is a single name we can derefence it + (sql-ident-attribute + (with-slots (qualifier (inner-name name)) name + (if qualifier + (flatten-id name) + (database-identifier inner-name)))) + (sql-ident + (with-slots ((inner-name name)) name + (database-identifier inner-name))) + ;; dont know how to handle this really :/ + (%sql-expression (flatten-id name)) + ))) + diff --git a/sql/fddl.lisp b/sql/fddl.lisp index 2c28ab2..267ee29 100644 --- a/sql/fddl.lisp +++ b/sql/fddl.lisp @@ -16,16 +16,6 @@ (in-package #:clsql-sys) -;; Utilities - -(defun database-identifier (name database) - (sql-escape (etypecase name - ;; honor case of strings - (string name) - (sql-ident (sql-output name database)) - (symbol (sql-output name database))))) - - ;; Truncate database (defun truncate-database (&key (database *default-database*)) @@ -79,20 +69,14 @@ supports transactions." *DEFAULT-DATABASE*. If the table does not exist and IF-DOES-NOT-EXIST is :ignore then DROP-TABLE returns nil whereas an error is signalled if IF-DOES-NOT-EXIST is :error." - (let ((table-name (database-identifier name database))) (ecase if-does-not-exist (:ignore - (unless (table-exists-p table-name :database database - :owner owner) + (unless (table-exists-p name :database database :owner owner) (return-from drop-table nil))) (:error t)) - - (let ((expr (etypecase name - ;; keep quotes for strings for mixed-case names - (string (format nil "DROP TABLE ~S" table-name)) - ((or symbol sql-ident) - (concatenate 'string "DROP TABLE " table-name))))) + + (let ((expr (concatenate 'string "DROP TABLE " (escaped-database-identifier name database)))) ;; Fixme: move to clsql-oracle (when (and (find-package 'clsql-oracle) (eq :oracle (database-type database)) @@ -101,7 +85,7 @@ an error is signalled if IF-DOES-NOT-EXIST is :error." (symbol-name '#:clsql-oracle))))) (setq expr (concatenate 'string expr " PURGE"))) - (execute-command expr :database database)))) + (execute-command expr :database database))) (defun list-tables (&key (owner nil) (database *default-database*)) "Returns a list of strings representing table names in DATABASE @@ -115,7 +99,7 @@ listed. If OWNER is :all then all tables are listed." (unless database (setf database *default-database*)) (let ((name (database-identifier name database)) (tables (list-tables :owner owner :database database))) - (when (member name tables :test #'string-equal) + (when (member name tables :test #'database-identifier-equal) t))) (defun table-exists-p (name &key (owner nil) (database *default-database*)) @@ -138,10 +122,7 @@ 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))) + (let* ((view-name (database-identifier name)) (stmt (make-instance 'sql-create-view :name view-name :column-list column-list @@ -155,15 +136,14 @@ checked to ensure that the new data satisfy the query AS." *DEFAULT-DATABASE*. If the view does not exist and IF-DOES-NOT-EXIST is :ignore then DROP-VIEW returns nil whereas an error is signalled if IF-DOES-NOT-EXIST is :error." - (let ((view-name (database-identifier name database))) (ecase if-does-not-exist (:ignore - (unless (view-exists-p view-name :database database) + (unless (view-exists-p name :database database) (return-from drop-view))) (:error t)) - (let ((expr (concatenate 'string "DROP VIEW " view-name))) - (execute-command expr :database database)))) + (let ((expr (concatenate 'string "DROP VIEW " (escaped-database-identifier name database)))) + (execute-command expr :database database))) (defun list-views (&key (owner nil) (database *default-database*)) "Returns a list of strings representing view names in DATABASE @@ -181,7 +161,7 @@ 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) + :test #'database-identifier-equal) t)) @@ -195,9 +175,10 @@ 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))) + (let* ((index-name (escaped-database-identifier name database)) + (table-name (escaped-database-identifier on database)) + (attributes (mapcar #'(lambda (a) (escaped-database-identifier a database)) + (listify attributes))) (stmt (format nil "CREATE ~A INDEX ~A ON ~A (~{~A~^, ~})" (if unique "UNIQUE" "") index-name table-name attributes))) @@ -212,20 +193,22 @@ 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)) - (let* ((db-type (database-underlying-type database)) - (index-identifier (cond ((db-type-use-fully-qualified-column-on-drop-index? db-type) - (format nil "~A.~A" (database-identifier on database) index-name)) - ((db-type-use-column-on-drop-index? db-type) - (format nil "~A ON ~A" index-name (database-identifier on database))) - (t index-name)))) - (execute-command (format nil "DROP INDEX ~A" index-identifier) - :database database)))) + (ecase if-does-not-exist + (:ignore + (unless (index-exists-p name :database database) + (return-from drop-index))) + (:error t)) + (let* ((db-type (database-underlying-type database)) + (on (when on (escaped-database-identifier on database))) + (index-name (escaped-database-identifier name database)) + (index-identifier + (cond ((db-type-use-fully-qualified-column-on-drop-index? db-type) + (format nil "~A.~A" on index-name)) + ((db-type-use-column-on-drop-index? db-type) + (format nil "~A ON ~A" index-name on)) + (t index-name)))) + (execute-command (format nil "DROP INDEX ~A" index-identifier) + :database database))) (defun list-indexes (&key (owner nil) (database *default-database*) (on nil)) "Returns a list of strings representing index names in DATABASE @@ -240,12 +223,14 @@ expression representing a table name in DATABASE or a list of such table identifiers." (if (null on) (database-list-indexes database :owner owner) - (let ((tables (typecase on (cons on) (t (list on))))) - (reduce #'append - (mapcar #'(lambda (table) (database-list-table-indexes - (database-identifier table database) - database :owner owner)) - tables))))) + (let ((tables (typecase on + (cons on) + (t (list on))))) + (reduce + #'append + (mapcar #'(lambda (table) + (database-list-table-indexes table database :owner owner)) + tables))))) (defun index-exists-p (name &key (owner nil) (database *default-database*)) "Tests for the existence of an SQL index called NAME in DATABASE @@ -256,7 +241,7 @@ 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) + :test #'database-identifier-equal) t)) ;; Attributes @@ -324,7 +309,7 @@ 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 + (database-list-attributes (escaped-database-identifier name database) database :owner owner)) (defun attribute-type (attribute table &key (owner nil) @@ -338,8 +323,8 @@ 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-attribute-type (escaped-database-identifier attribute database) + (escaped-database-identifier table database) database :owner owner)) @@ -357,7 +342,7 @@ 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))) + (let ((table-ident (escaped-database-identifier table database))) (multiple-value-bind (val found) (gethash table-ident attribute-cache) (if (and found (second val)) (second val) @@ -365,7 +350,7 @@ the attribute accepts null values and otherwise 0." (cons attribute (multiple-value-list (database-attribute-type - (database-identifier attribute + (escaped-database-identifier attribute database) table-ident database @@ -397,13 +382,12 @@ the attribute accepts null values and otherwise 0." *DEFAULT-DATABASE*. If the sequence does not exist and IF-DOES-NOT-EXIST is :ignore then DROP-SEQUENCE returns nil whereas an error is signalled if IF-DOES-NOT-EXIST is :error." - (let ((sequence-name (database-identifier name database))) - (ecase if-does-not-exist - (:ignore - (unless (sequence-exists-p sequence-name :database database) - (return-from drop-sequence))) - (:error t)) - (database-drop-sequence sequence-name database)) + (ecase if-does-not-exist + (:ignore + (unless (sequence-exists-p name :database database) + (return-from drop-sequence))) + (:error t)) + (database-drop-sequence name database) (values)) (defun list-sequences (&key (owner nil) (database *default-database*)) @@ -423,10 +407,13 @@ 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)) + (let ((seqs (list-sequences :owner owner :database database)) + ;; handle symbols, we know the db will return strings + (n1 (database-identifier name database)) + (n2 (%sequence-name-to-table name database))) + (when (or (member n1 seqs :test #'database-identifier-equal) + (member n2 seqs :test #'database-identifier-equal)) + t))) (defun sequence-next (name &key (database *default-database*)) "Increment and return the next value in the sequence called diff --git a/sql/fdml.lisp b/sql/fdml.lisp index b9a1153..bd8d6d3 100644 --- a/sql/fdml.lisp +++ b/sql/fdml.lisp @@ -135,7 +135,7 @@ columns." (subquery nil)) (unless into (error 'sql-user-error :message ":into keyword not supplied")) - (let ((insert (make-instance 'sql-insert :into into))) + (let ((insert (make-instance 'sql-insert :into (database-identifier into nil)))) (with-slots (attributes values query) insert @@ -163,7 +163,7 @@ columns." "Deletes records satisfying the SQL expression WHERE from the table specified by FROM in DATABASE specifies a database which defaults to *DEFAULT-DATABASE*." - (let ((stmt (make-instance 'sql-delete :from from :where where))) + (let ((stmt (make-instance 'sql-delete :from (database-identifier from database) :where where))) (execute-command stmt :database database))) (defun update-records (table &key (attributes nil) @@ -184,7 +184,7 @@ 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 + (let ((stmt (make-instance 'sql-update :table (database-identifier table database) :attributes attributes :values values :where where))) diff --git a/sql/generic-postgresql.lisp b/sql/generic-postgresql.lisp index 83c552f..1d1fbf0 100644 --- a/sql/generic-postgresql.lisp +++ b/sql/generic-postgresql.lisp @@ -127,8 +127,8 @@ (database-query (format nil - "select indexrelid from pg_index where indrelid=(select relfilenode from pg_class where relname='~A'~A)" - (string-downcase table) + "select indexrelid from pg_index where indrelid=(select relfilenode from pg_class where LOWER(relname)='~A'~A)" + (string-downcase (unescaped-database-identifier table)) (owner-clause owner)) database :auto nil)) (result nil)) @@ -202,14 +202,15 @@ (defmethod database-create-sequence (sequence-name (database generic-postgresql-database)) - (database-execute-command - (concatenate 'string "CREATE SEQUENCE " (sql-escape sequence-name)) - database)) + (let ((cmd (concatenate + 'string "CREATE SEQUENCE " (escaped-database-identifier sequence-name database)))) + (database-execute-command cmd database))) (defmethod database-drop-sequence (sequence-name (database generic-postgresql-database)) (database-execute-command - (concatenate 'string "DROP SEQUENCE " (sql-escape sequence-name)) database)) + (concatenate 'string "DROP SEQUENCE " (escaped-database-identifier sequence-name database)) + database)) (defmethod database-list-sequences ((database generic-postgresql-database) &key (owner nil)) @@ -221,7 +222,7 @@ (parse-integer (caar (database-query - (format nil "SELECT SETVAL ('~A', ~A)" name position) + (format nil "SELECT SETVAL ('~A', ~A)" (escaped-database-identifier name) position) database nil nil))))) (defmethod database-sequence-next (sequence-name @@ -230,7 +231,7 @@ (parse-integer (caar (database-query - (concatenate 'string "SELECT NEXTVAL ('" (sql-escape sequence-name) "')") + (concatenate 'string "SELECT NEXTVAL ('" (escaped-database-identifier sequence-name) "')") database nil nil))))) (defmethod database-sequence-last (sequence-name (database generic-postgresql-database)) @@ -238,56 +239,68 @@ (parse-integer (caar (database-query - (concatenate 'string "SELECT LAST_VALUE FROM " sequence-name) + (concatenate 'string "SELECT LAST_VALUE FROM " (escaped-database-identifier sequence-name)) database nil nil))))) +(defmethod auto-increment-sequence-name (table column (database generic-postgresql-database)) + (let* ((sequence-name (or (database-identifier (slot-value column 'autoincrement-sequence)) + (combine-database-identifiers + (list table column 'seq) + database)))) + (when (search "'" (escaped-database-identifier sequence-name) + :test #'string-equal) + (signal-database-too-strange + "PG Sequence names shouldnt contain single quotes for the sake of sanity")) + sequence-name)) + (defmethod database-last-auto-increment-id ((database generic-postgresql-database) table column) - (let (column-helper seq-name) - (typecase table - (sql-ident (setf table (slot-value table 'name))) - (standard-db-class (setf table (view-table table)))) - (typecase column - (sql-ident (setf column-helper (slot-value column 'name))) - (view-class-slot-definition-mixin - (setf column-helper (view-class-slot-column column)))) - (setq seq-name (or (view-class-slot-autoincrement-sequence column) - (convert-to-db-default-case (format nil "~a_~a_seq" table column-helper) database))) - (first (clsql:query (format nil "SELECT currval ('~a')" seq-name) + (let ((seq-name (auto-increment-sequence-name table column database))) + (first (clsql:query (format nil "SELECT currval ('~a')" + (escaped-database-identifier seq-name)) :flatp t :database database :result-types '(:int))))) -(defmethod database-generate-column-definition (class slotdef (database generic-postgresql-database)) - ; handle autoincr slots special - (when (or (and (listp (view-class-slot-db-constraints slotdef)) - (member :auto-increment (view-class-slot-db-constraints slotdef))) - (eql :auto-increment (view-class-slot-db-constraints slotdef)) - (slot-value slotdef 'autoincrement-sequence)) - (let ((sequence-name (database-make-autoincrement-sequence class slotdef database))) - (setf (view-class-slot-autoincrement-sequence slotdef) sequence-name) - (cond ((listp (view-class-slot-db-constraints slotdef)) - (setf (view-class-slot-db-constraints slotdef) - (remove :auto-increment - (view-class-slot-db-constraints slotdef))) - (unless (member :default (view-class-slot-db-constraints slotdef)) - (setf (view-class-slot-db-constraints slotdef) - (append - (list :default (format nil "nextval('~a')" sequence-name)) - (view-class-slot-db-constraints slotdef))))) - (t - (setf (view-class-slot-db-constraints slotdef) - (list :default (format nil "nextval('~a')" sequence-name))))))) - (call-next-method class slotdef database)) - -(defmethod database-make-autoincrement-sequence (table column (database generic-postgresql-database)) - (let* ((table-name (view-table table)) - (column-name (view-class-slot-column column)) - (sequence-name (or (slot-value column 'autoincrement-sequence) - (convert-to-db-default-case - (format nil "~a_~a_SEQ" table-name column-name) database)))) - (unless (sequence-exists-p sequence-name :database database) - (database-create-sequence sequence-name database)) - sequence-name)) +(defmethod database-generate-column-definition + (class slotdef (database generic-postgresql-database)) + (when (member (view-class-slot-db-kind slotdef) '(:base :key)) + (let ((cdef + (list (sql-expression :attribute (database-identifier slotdef database)) + (specified-type slotdef) + (view-class-slot-db-type slotdef))) + (const (listify (view-class-slot-db-constraints slotdef))) + (seq (auto-increment-sequence-name class slotdef database))) + (when seq + (setf const (remove :auto-increment const)) + (unless (member :default const) + (let* ((next (format nil "nextval('~a')" (escaped-database-identifier seq)))) + (setf const (append const (list :default next)))))) + (append cdef const)))) + +(defmethod database-add-autoincrement-sequence + ((self standard-db-class) (database generic-postgresql-database)) + (let ((ordered-slots (if (normalizedp self) + (ordered-class-direct-slots self) + (ordered-class-slots self)))) + (dolist (slotdef ordered-slots) + + ;; ensure that referenceed sequences actually exist before referencing them + (let ((sequence-name (auto-increment-sequence-name self slotdef database))) + (when (and sequence-name + (not (sequence-exists-p sequence-name :database database))) + (create-sequence sequence-name :database database)))))) + +(defmethod database-remove-autoincrement-sequence + ((table standard-db-class) + (database generic-postgresql-database)) + (let ((ordered-slots + (if (normalizedp table) + (ordered-class-direct-slots table) + (ordered-class-slots table)))) + (dolist (slotdef ordered-slots) + ;; ensure that referenceed sequences are dropped with the table + (let ((sequence-name (auto-increment-sequence-name table slotdef database))) + (when sequence-name (drop-sequence sequence-name)))))) (defun postgresql-database-list (connection-spec type) (destructuring-bind (host name &rest other-args) connection-spec diff --git a/sql/generics.lisp b/sql/generics.lisp index 3f3ee7c..0d1a4da 100644 --- a/sql/generics.lisp +++ b/sql/generics.lisp @@ -144,12 +144,29 @@ DATABASE-NULL-VALUE on the type of the slot.")) ) (defgeneric read-sql-value (val type database db-type) ) -(defgeneric database-make-autoincrement-sequence (class slotdef database) - ) +(defgeneric database-add-autoincrement-sequence (class database) + (:method (class database) nil) + (:documentation "If a database needs to add a sequence for its + autoincrement to work, this is where it should go. Default is + that it doesnt so just return nil")) +(defgeneric database-remove-autoincrement-sequence (class database) + (:method (class database) nil) + (:documentation "If a database needs to add a sequence for its + autoincrement to work, this is where it should go. Default is + that it doesnt so just return nil")) +(defgeneric auto-increment-sequence-name (class slotdef database) + (:documentation "The sequence name to create for this autoincremnt column on this class + if returns nil, there is no associated sequence ")) + +(defmethod auto-increment-sequence-name :around (class slot database) + (when (auto-increment-column-p slot database) + (call-next-method))) (defgeneric database-last-auto-increment-id (database table column) ) + + ;; Generation of SQL strings from lisp expressions (defgeneric output-sql (expr database) diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp index 81a430c..df3c36e 100644 --- a/sql/metaclasses.lisp +++ b/sql/metaclasses.lisp @@ -83,15 +83,6 @@ ((stringp arg) (sql-escape arg)))) -(defun column-name-from-arg (arg) - (cond ((symbolp arg) - arg) - ((typep arg 'sql-ident) - (slot-value arg 'name)) - ((stringp arg) - (intern (symbol-name-default-case arg))))) - - (defun remove-keyword-arg (arglist akey) (let ((mylist arglist) (newlist ())) @@ -445,12 +436,7 @@ implementations." list)) (declaim (inline delistify-dsd)) -(defun delistify-dsd (list) - "Some MOPs, like openmcl 0.14.2, cons attribute values in a list." - (if (and (listp list) (null (cdr list))) - (car list) - list)) - +;; there is an :after method below too (defmethod initialize-instance :around ((obj view-class-direct-slot-definition) &rest initargs &key db-constraints db-kind type &allow-other-keys) @@ -465,6 +451,14 @@ implementations." type db-constraints)) initargs)) +(defun compute-column-name (arg) + (database-identifier arg nil)) + +(defmethod initialize-instance :after + ((obj view-class-direct-slot-definition) + &key &allow-other-keys) + (setf (view-class-slot-column obj) (compute-column-name obj))) + (defmethod compute-effective-slot-definition ((class standard-db-class) #+kmr-normal-cesd slot-name direct-slots) @@ -476,15 +470,7 @@ implementations." (let ((esd (call-next-method))) (typecase dsd (view-class-slot-definition-mixin - ;; Use the specified :column argument if it is supplied, otherwise - ;; the column slot is filled in with the slot-name, but transformed - ;; to be sql safe, - to _ and such. - (setf (slot-value esd 'column) - (column-name-from-arg - (if (slot-boundp dsd 'column) - (delistify-dsd (view-class-slot-column dsd)) - (column-name-from-arg - (sql-escape (slot-definition-name dsd)))))) + (setf (slot-value esd 'column) (compute-column-name dsd)) (setf (slot-value esd 'db-type) (when (slot-boundp dsd 'db-type) @@ -555,10 +541,8 @@ implementations." #+openmcl (setf (slot-value esd 'ccl::type-predicate) type-predicate))) - (setf (slot-value esd 'column) - (column-name-from-arg - (sql-escape (slot-definition-name dsd)))) - + ;; has no column name if it is not a database column + (setf (slot-value esd 'column) nil) (setf (slot-value esd 'db-info) nil) (setf (slot-value esd 'db-kind) :virtual) (setf (specified-type esd) (slot-definition-type dsd))) @@ -588,3 +572,22 @@ implementations." #+kmr-normal-esdc (setq cl:*features* (delete :kmr-normal-esdc cl:*features*)) ) + +(defmethod database-identifier ( (name standard-db-class) + &optional database find-class-p) + "the majority of this function is in expressions.lisp + this is here to make loading be less painful (try-recompiles) in SBCL" + (database-identifier (view-table name) database)) + +(defmethod database-identifier ((name view-class-slot-definition-mixin) + &optional database find-class-p) + (database-identifier + (if (slot-boundp name 'column) + (delistify-dsd (view-class-slot-column name)) + (slot-definition-name name)) + database)) + +(defun find-standard-db-class (name &aux cls) + (and (setf cls (ignore-errors (find-class name))) + (typep cls 'standard-db-class) + cls)) diff --git a/sql/ooddl.lisp b/sql/ooddl.lisp index 02c11f0..2d1d73b 100644 --- a/sql/ooddl.lisp +++ b/sql/ooddl.lisp @@ -91,13 +91,17 @@ in DATABASE which defaults to *DEFAULT-DATABASE*." (if tclass (let ((*default-database* database) (pclass (car (class-direct-superclasses tclass)))) - (when (and (normalizedp tclass) (not (table-exists-p (view-table pclass)))) + (when (and (normalizedp tclass) (not (table-exists-p pclass))) (create-view-from-class (class-name pclass) :database database :transactions transactions)) (%install-class tclass database :transactions transactions)) (error "Class ~s not found." view-class-name))) (values)) +(defmethod auto-increment-column-p (slotdef &optional (database clsql-sys:*default-database*)) + (declare (ignore database)) + (or (member :auto-increment (listify (view-class-slot-db-constraints slotdef))) + (slot-value slotdef 'autoincrement-sequence))) (defmethod %install-class ((self standard-db-class) database &key (transactions t)) @@ -106,15 +110,16 @@ in DATABASE which defaults to *DEFAULT-DATABASE*." (ordered-class-direct-slots self) (ordered-class-slots self)))) (dolist (slotdef ordered-slots) - (let ((res (database-generate-column-definition self - slotdef database))) + (let ((res (database-generate-column-definition self slotdef database))) (when res (push res schemadef)))) (if (not schemadef) (unless (normalizedp self) (error "Class ~s has no :base slots" self)) (progn - (create-table (sql-expression :table (view-table self)) (nreverse schemadef) + (database-add-autoincrement-sequence self database) + (create-table (sql-expression :table (database-identifier self database)) + (nreverse schemadef) :database database :transactions transactions :constraints (database-pkey-constraint self database)) @@ -122,22 +127,21 @@ in DATABASE which defaults to *DEFAULT-DATABASE*." t) (defmethod database-pkey-constraint ((class standard-db-class) database) - (let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class))) - (table (view-table class))) + ;; Keylist will always be a list of escaped-indentifier + (let ((keylist (mapcar #'(lambda (x) (escaped-database-identifier x database)) + (keyslots-for-class class))) + (table (escaped (combine-database-identifiers + (list class 'PK) + database)))) (when keylist - (etypecase table - (string - (format nil "CONSTRAINT \"~APK\" PRIMARY KEY~A" table - (sql-output keylist database))) - ((or symbol sql-ident) - (format nil "CONSTRAINT ~APK PRIMARY KEY~A" table - (sql-output keylist database))))))) + (format nil "CONSTRAINT ~A PRIMARY KEY (~{~A~^,~})" table + keylist)))) (defmethod database-generate-column-definition (class slotdef database) - (declare (ignore database class)) + (declare (ignore class)) (when (member (view-class-slot-db-kind slotdef) '(:base :key)) (let ((cdef - (list (sql-expression :attribute (view-class-slot-column slotdef)) + (list (sql-expression :attribute (database-identifier slotdef database)) (specified-type slotdef)))) (setf cdef (append cdef (list (view-class-slot-db-type slotdef)))) (let ((const (view-class-slot-db-constraints slotdef))) @@ -164,10 +168,11 @@ DATABASE which defaults to *DEFAULT-DATABASE*." (defun %uninstall-class (self &key (database *default-database*) (owner nil)) - (drop-table (sql-expression :table (view-table self)) + (drop-table (sql-expression :table (database-identifier self database)) :if-does-not-exist :ignore :database database :owner owner) + (database-remove-autoincrement-sequence self database) (setf (database-view-classes database) (remove self (database-view-classes database)))) diff --git a/sql/oodml.lisp b/sql/oodml.lisp index 99cf021..ecfc9fa 100644 --- a/sql/oodml.lisp +++ b/sql/oodml.lisp @@ -19,7 +19,7 @@ (flet ((qfk (k) (sql-operation '== (sql-expression :attribute - (view-class-slot-column k) + (database-identifier k database) :table tb) (db-value-from-slot k @@ -39,11 +39,11 @@ (defun generate-attribute-reference (vclass slotdef) (cond ((eq (view-class-slot-db-kind slotdef) :base) - (sql-expression :attribute (view-class-slot-column slotdef) - :table (view-table vclass))) + (sql-expression :attribute (database-identifier slotdef nil) + :table (database-identifier vclass nil))) ((eq (view-class-slot-db-kind slotdef) :key) - (sql-expression :attribute (view-class-slot-column slotdef) - :table (view-table vclass))) + (sql-expression :attribute (database-identifier slotdef nil) + :table (database-identifier vclass nil))) (t nil))) ;; @@ -196,7 +196,7 @@ (let* ((vct (view-table view-class)) (sd (slotdef-for-slot-with-class slot view-class))) (check-slot-type sd (slot-value obj slot)) - (let* ((att (view-class-slot-column sd)) + (let* ((att (database-identifier sd database)) (val (db-value-from-slot sd (slot-value obj slot) database))) (cond ((and vct sd (view-database obj)) (update-records (sql-expression :table vct) @@ -232,7 +232,7 @@ obj (slot-definition-name s)))) (check-slot-type s val) (list (sql-expression - :attribute (view-class-slot-column s)) + :attribute (database-identifier s database)) (db-value-from-slot s val database)))) sds))) (cond ((and avps (view-database obj)) @@ -263,7 +263,7 @@ (slot-value-list (slot) (let ((value (slot-value obj (slot-definition-name slot)))) (check-slot-type slot value) - (list (sql-expression :attribute (view-class-slot-column slot)) + (list (sql-expression :attribute (database-identifier slot database)) (db-value-from-slot slot value database))))) (let* ((view-class (or this-class (class-of obj))) (pk-slot (car (keyslots-for-class view-class))) @@ -304,12 +304,11 @@ :database database) (when (and pk-slot (not pk)) - (setf pk (if (or (member :auto-increment (listify (view-class-slot-db-constraints pk-slot))) - (not (null (view-class-slot-autoincrement-sequence pk-slot)))) - (setf (slot-value obj (slot-definition-name pk-slot)) - (database-last-auto-increment-id database - view-class-table - pk-slot))))) + (setf pk + (when (auto-increment-column-p pk-slot database) + (setf (slot-value obj (slot-definition-name pk-slot)) + (database-last-auto-increment-id + database view-class-table pk-slot))))) (when pk-slot (setf pk (or pk (slot-value @@ -406,7 +405,7 @@ (sld (slotdef-for-slot-with-class slot class))) (if sld (if (eq value +no-slot-value+) - (sql-expression :attribute (view-class-slot-column sld) + (sql-expression :attribute (database-identifier sld database) :table (view-table class)) (db-value-from-slot sld @@ -941,8 +940,8 @@ maximum of MAX-LEN instances updated in each query." (symbol (sql-expression :attribute - (view-class-slot-column - (slotdef-for-slot-with-class fk sc)) + (database-identifier + (slotdef-for-slot-with-class fk sc) nil) :table (view-table sc))) (t fk)) (typecase hk @@ -989,8 +988,8 @@ maximum of MAX-LEN instances updated in each query." (symbol (sql-expression :attribute - (view-class-slot-column fksd) - :table (view-table jc))) + (database-identifier fksd nil) + :table (database-identifier jc nil))) (t fk)) (typecase hk (symbol @@ -1092,11 +1091,7 @@ maximum of MAX-LEN instances updated in each query." (declare (ignore all set-operation group-by having offset limit inner-join on)) (flet ((ref-equal (ref1 ref2) (string= (sql-output ref1 database) - (sql-output ref2 database))) - (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)))))) + (sql-output ref2 database)))) (remf args :from) (remf args :where) (remf args :flatp) @@ -1126,7 +1121,7 @@ maximum of MAX-LEN instances updated in each query." jc-list)) immediate-join-classes) sel-tables) - :test #'tables-equal))) + :test #'database-identifier-equal))) (order-by-slots (mapcar #'(lambda (ob) (if (atom ob) ob (car ob))) (listify order-by))) (join-where nil)) diff --git a/sql/sequences.lisp b/sql/sequences.lisp index 5800e59..3e9a2e4 100644 --- a/sql/sequences.lisp +++ b/sql/sequences.lisp @@ -21,15 +21,10 @@ ;;; Sequence functions (defun %sequence-name-to-table (sequence-name database) - (concatenate 'string - (convert-to-db-default-case "_CLSQL_SEQ_" database) - (sql-escape sequence-name))) - -(defun %table-name-to-sequence-name (table-name database) - (and (>= (length table-name) 11) - (string-equal (subseq table-name 0 11) - (convert-to-db-default-case "_CLSQL_SEQ_" database)) - (subseq table-name 11))) + (escaped + (combine-database-identifiers + (list sequence-name 'CLSQL_SEQ) + database))) (defmethod database-create-sequence (sequence-name database) (let ((table-name (%sequence-name-to-table sequence-name database))) @@ -47,11 +42,17 @@ (concatenate 'string "DROP TABLE " (%sequence-name-to-table sequence-name database)) database)) +(defun %table-name-to-sequence-name (table-name) + ;; if this was escaped it still should be, + ;; if it wasnt it still shouldnt-be + (check-type table-name string) + (replace-all table-name "_CLSQL_SEQ" "")) + (defmethod database-list-sequences (database &key (owner nil)) (declare (ignore owner)) (mapcan #'(lambda (s) - (let ((sn (%table-name-to-sequence-name s database))) - (and sn (list sn)))) + (and (search "_CLSQL_SEQ" s :test #'string-equal) + (list (%table-name-to-sequence-name s)))) (database-list-tables-and-sequences database))) (defmethod database-set-sequence-position (sequence-name position database) diff --git a/sql/syntax.lisp b/sql/syntax.lisp index 7e1906b..4ec07f5 100644 --- a/sql/syntax.lisp +++ b/sql/syntax.lisp @@ -155,7 +155,7 @@ keyword arguments is specified." (string (make-instance 'sql :string string)) (attribute - (make-instance 'sql-ident-attribute :name attribute + (make-instance 'sql-ident-attribute :name attribute :qualifier (or table alias) :type type)) ((and table (not attribute)) diff --git a/sql/utils.lisp b/sql/utils.lisp index 515dc49..b43e318 100644 --- a/sql/utils.lisp +++ b/sql/utils.lisp @@ -375,3 +375,20 @@ list of characters and replacement strings." (eval-when (:compile-toplevel :load-toplevel :execute) (setq cl:*features* (delete :clsql-lowercase-reader cl:*features*))) +(defun replace-all (string part replacement &key (test #'char=) stream) + "Returns a new string in which all the occurences of the part +is replaced with replacement. [FROM http://cl-cookbook.sourceforge.net/strings.html#manip]" + (let ((out (or stream (make-string-output-stream)))) + (loop with part-length = (length part) + for old-pos = 0 then (+ pos part-length) + for pos = (search part string + :start2 old-pos + :test test) + do (write-string string out + :start old-pos + :end (or pos (length string))) + when pos do (write-string replacement out) + while pos) + (unless stream + (get-output-stream-string out)))) + diff --git a/tests/datasets.lisp b/tests/datasets.lisp index 1e92241..63f1cd3 100644 --- a/tests/datasets.lisp +++ b/tests/datasets.lisp @@ -67,9 +67,7 @@ should we debug (T) or just print and quit.") (defun %dataset-init (name) "Run initialization code and fill database for given dataset." - (handler-bind - ((error #'generic-error)) - ;;find items that looks like '(:setup ...), + ;;find items that looks like '(:setup ...), ;; dispatch the rest. (let ((setup (rest (find :setup name :key #'first))) (sqldata (rest (find :sqldata name :key #'first))) @@ -88,7 +86,7 @@ should we debug (T) or just print and quit.") ;;presumed to be view-class objects, force them to insert. (dolist (o objdata) (setf (slot-value o 'clsql-sys::view-database) nil) - (clsql-sys:update-records-from-instance o)))))) + (clsql-sys:update-records-from-instance o))))) (defun %dataset-cleanup (name) "Run cleanup code associated with the given dataset." -- 2.34.1