X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fexpressions.lisp;h=10bdb5ec0b2a0dd23e7d85032da5f180e1b45315;hp=7a8c11a6b226d1202ad6158830a4f0a8fd701676;hb=374df8f34a7214e08fc4cfc5d734d024acdbf9ca;hpb=3b7cb72a2117fe5e4599da811c9e2821de02824b diff --git a/sql/expressions.lisp b/sql/expressions.lisp index 7a8c11a..10bdb5e 100644 --- a/sql/expressions.lisp +++ b/sql/expressions.lisp @@ -68,6 +68,14 @@ #\^ #\& #\* #\| #\( #\) #\- #\+ #\< #\> #\{ #\})))) +(defun special-cased-symbol-p (sym) + "Should the symbols case be preserved, or should we convert to default casing" + (let ((name (symbol-name sym))) + (case (readtable-case *readtable*) + (:upcase (not (string= (string-upcase name) name))) + (:downcase (not (string= (string-downcase name) name))) + (t t)))) + (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." @@ -88,8 +96,12 @@ (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))))))) + (%escape-identifier + (if (special-cased-symbol-p inp) + s + (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) @@ -237,6 +249,10 @@ (declare (ignore sql)) nil) +(defmethod collect-table-refs ((sql list)) + (loop for i in sql + appending (listify (collect-table-refs i)))) + (defmethod collect-table-refs ((sql sql-ident-attribute)) (let ((qual (slot-value sql 'qualifier))) (when qual @@ -274,6 +290,9 @@ sql `(make-instance 'sql-ident-table :name ',name :table-alias ',alias))) +(defmethod collect-table-refs ((sql sql-ident-table)) + (list sql)) + (defmethod output-sql ((expr sql-ident-table) database) (with-slots (name alias) expr (flet ((p (s) ;; the etypecase is in sql-escape too @@ -1074,45 +1093,40 @@ uninclusive, and the args from that keyword to the end." ;; ;; Column constraint types and conversion to SQL ;; - -(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") - (cons (symbol-name-default-case "UNSIGNED") "UNSIGNED") - (cons (symbol-name-default-case "ZEROFILL") "ZEROFILL") - (cons (symbol-name-default-case "AUTO-INCREMENT") "AUTO_INCREMENT") - (cons (symbol-name-default-case "DEFAULT") "DEFAULT") - (cons (symbol-name-default-case "UNIQUE") "UNIQUE") - (cons (symbol-name-default-case "IDENTITY") "IDENTITY (1,1)") ;; added for sql-server support - )) - (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)))) - (when (equal (symbol-name (car constraint)) "DEFAULT") - (setq constraint (cdr constraint)) - (setq string (concatenate 'string string " " (car constraint)))) - (if (< 1 (length constraint)) - (setq string (concatenate 'string string " ")))))))) + (make-constraints-description constraint-list database)) + +;; KEEP THIS SYNCED WITH database-translate-constraint +(defparameter +auto-increment-names+ + '(:auto-increment :auto_increment :autoincrement :identity)) + +(defmethod database-translate-constraint (constraint database) + (case constraint + (:not-null "NOT NULL") + (:primary-key "PRIMARY KEY") + ((:auto-increment :auto_increment :autoincrement :identity) + (ecase (database-underlying-type database) + (:mssql "IDENTITY (1,1)") + ((:sqlite :sqlite3) "PRIMARY KEY AUTOINCREMENT") + (:mysql "AUTO_INCREMENT"))) + ;; everything else just get the name + (T (string-upcase (symbol-name constraint))))) + +(defun make-constraints-description (constraint-list database + &aux (rest constraint-list) constraint) + (when constraint-list + (flet ((next () + (setf constraint (first rest) + rest (rest rest)) + constraint)) + (with-output-to-string (s) + (loop while (next) + do (unless (keywordp constraint) + (setf constraint (intern (symbol-name constraint) :keyword))) + (write-string (database-translate-constraint constraint database) s) + (when (eql :default constraint) (princ (next) s)) + (write-char #\space s) + ))))) (defmethod database-identifier ( name &optional database find-class-p &aux cls) @@ -1170,3 +1184,51 @@ uninclusive, and the args from that keyword to the end." (%sql-expression (flatten-id name)) ))) +(defun %clsql-subclauses (clauses) + "a helper for dealing with lists of sql clauses" + (loop for c in clauses + when c + collect (typecase c + (string (clsql-sys:sql-expression :string c)) + (T c)))) + +(defun clsql-ands (clauses) + "Correctly creates a sql 'and' expression for the clauses + ignores any nil clauses + returns a single child expression if there is only one + returns an 'and' expression if there are many + returns nil if there are no children" + (let ((ex (%clsql-subclauses clauses))) + (when ex + (case (length ex) + (1 (first ex)) + (t (apply #'clsql-sys:sql-and ex)))))) + +(defun clsql-and (&rest clauses) + "Correctly creates a sql 'and' expression for the clauses + ignores any nil clauses + returns a single child expression if there is only one + returns an 'and' expression if there are many + returns nil if there are no children" + (clsql-ands clauses)) + +(defun clsql-ors (clauses) + "Correctly creates a sql 'or' expression for the clauses + ignores any nil clauses + returns a single child expression if there is only one + returns an 'or' expression if there are many + returns nil if there are no children" + (let ((ex (%clsql-subclauses clauses))) + (when ex + (case (length ex) + (1 (first ex)) + (t (apply #'clsql-sys:sql-or ex)))))) + +(defun clsql-or (&rest clauses) + "Correctly creates a sql 'or' expression for the clauses + ignores any nil clauses + returns a single child expression if there is only one + returns an 'or' expression if there are many + returns nil if there are no children" + (clsql-ors clauses)) +