From b5890c31a60303397efedb2110f46c6388426170 Mon Sep 17 00:00:00 2001 From: Marcus Pearce Date: Fri, 16 Jul 2004 12:00:15 +0000 Subject: [PATCH] r9796: * sql/expressions.lisp: reactivate caching of generated SQL strings. Move methods for DATABASE-OUTPUT-SQL, OUTPUT-SQL and SQL-HASH-KEY here from sql/fdml.lisp. Rationalise behaviour of SQL-OUTPUT, OUTPUT-SQL and DATABASE-OUTPUT-SQL. * sql/fdml.lisp: remove disabled method ADD-STORAGE-CLASS. Move methods for DATABASE-OUTPUT-SQL, OUTPUT-SQL and SQL-HASH-KEY to sql/expressions.lisp. * sql/ooddl.lisp: replace call to DATABASE-OUTPUT-SQL in DATABASE-PKEY-CONSTRAINT with call to SQL-OUTPUT. * sql/generics.lisp: add docstrings. --- ChangeLog | 12 +++ sql/expressions.lisp | 184 +++++++++++++++++++++++++++++++------------ sql/fdml.lisp | 111 -------------------------- sql/generics.lisp | 39 ++++++--- sql/ooddl.lisp | 4 +- 5 files changed, 173 insertions(+), 177 deletions(-) diff --git a/ChangeLog b/ChangeLog index 42dc56a..fe3f1d2 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,15 @@ +16 Jul 2004 Marcus Pearce + * sql/expressions.lisp: reactivate caching of generated SQL strings. + Move methods for DATABASE-OUTPUT-SQL, OUTPUT-SQL and SQL-HASH-KEY + here from sql/fdml.lisp. Rationalise behaviour of SQL-OUTPUT, + OUTPUT-SQL and DATABASE-OUTPUT-SQL. + * sql/fdml.lisp: remove disabled method ADD-STORAGE-CLASS. Move + methods for DATABASE-OUTPUT-SQL, OUTPUT-SQL and SQL-HASH-KEY to + sql/expressions.lisp. + * sql/ooddl.lisp: replace call to DATABASE-OUTPUT-SQL in + DATABASE-PKEY-CONSTRAINT with call to SQL-OUTPUT. + * sql/generics.lisp: add docstrings. + 15 Jul 2004 Kevin Rosenberg * Version 2.11.16 * db-oracle/oracle-sql.lisp: Remove OpenMCL specific diff --git a/sql/expressions.lisp b/sql/expressions.lisp index 2a0085f..2f40e33 100644 --- a/sql/expressions.lisp +++ b/sql/expressions.lisp @@ -23,11 +23,39 @@ "stream which accumulates SQL output") (defun sql-output (sql-expr &optional database) + "Top-level call for generating SQL strings. Returns an SQL + string appropriate for DATABASE which corresponds to the + supplied lisp expression SQL-EXPR." (progv '(*sql-stream*) `(,(make-string-output-stream)) (output-sql sql-expr database) (get-output-stream-string *sql-stream*))) +(defmethod output-sql (expr database) + (write-string (database-output-sql expr database) *sql-stream*) + (values)) + +(defvar *output-hash* (make-hash-table :test #'equal) + "For caching generated SQL strings.") + +(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-hash-key (expr database) + (declare (ignore expr database)) + nil) + (defclass %sql-expression () ()) @@ -66,10 +94,11 @@ (sql-output ident nil))) ;; For SQL Identifiers of generic type + (defclass sql-ident (%sql-expression) ((name :initarg :name - :initform "NULL")) + :initform +null-string+)) (:documentation "An SQL identifer.")) (defmethod make-load-form ((sql sql-ident) &optional environment) @@ -78,27 +107,6 @@ 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 @@ -115,10 +123,10 @@ (defclass sql-ident-attribute (sql-ident) ((qualifier :initarg :qualifier - :initform "NULL") + :initform +null-string+) (type :initarg :type - :initform "NULL")) + :initform +null-string+)) (:documentation "An SQL Attribute identifier.")) (defmethod collect-table-refs (sql) @@ -169,12 +177,13 @@ 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))) + expr + (list (and database (database-underlying-type database)) + 'sql-ident-attribute qualifier name type))) ;; For SQL Identifiers for tables + (defclass sql-ident-table (sql-ident) ((alias :initarg :table-alias :initform nil)) @@ -197,21 +206,11 @@ (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))) + expr + (list (and database (database-underlying-type database)) + 'sql-ident-table name alias))) (defclass sql-relational-exp (%sql-expression) ((operator @@ -258,9 +257,6 @@ () (: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*) @@ -338,14 +334,10 @@ (: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)))) @@ -832,8 +824,100 @@ uninclusive, and the args from that keyword to the end." ;; -;; Column constraint types +;; DATABASE-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 ((zerop len) + +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 fixnum i j)) + (let ((char (aref str i))) + (declare (character char)) + (cond ((char= char #\') + (setf (aref buf j) #\') + (incf j) + (setf (aref buf j) #\')) + ((char= 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-string+ + (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 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 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))) + +#+ignore +(defmethod database-output-sql ((self money) database) + (database-output-sql (slot-value self 'odcl::units) database)) + +(defmethod database-output-sql (thing database) + (if (or (null thing) + (eq 'null thing)) + +null-string+ + (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))))) + + ;; +;; Column constraint types and conversion to SQL +;; + (defparameter *constraint-types* (list (cons (symbol-name-default-case "NOT-NULL") "NOT NULL") @@ -847,10 +931,6 @@ uninclusive, and the args from that keyword to the end." (cons (symbol-name-default-case "AUTO-INCREMENT") "AUTO_INCREMENT") (cons (symbol-name-default-case "UNIQUE") "UNIQUE"))) -;; -;; Convert type spec to sql syntax -;; - (defmethod database-constraint-statement (constraint-list database) (declare (ignore database)) (make-constraints-description constraint-list)) diff --git a/sql/fdml.lisp b/sql/fdml.lisp index 470ad37..943a157 100644 --- a/sql/fdml.lisp +++ b/sql/fdml.lisp @@ -192,117 +192,6 @@ are nil and AV-PAIRS is an alist of (attribute value) pairs." (execute-command stmt :database database))) -;; 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 ((zerop len) - +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 fixnum i j)) - (let ((char (aref str i))) - (declare (character char)) - (cond ((char= char #\') - (setf (aref buf j) #\') - (incf j) - (setf (aref buf j) #\')) - ((char= 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) - -#+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 diff --git a/sql/generics.lisp b/sql/generics.lisp index 5bc74ca..d8066cf 100644 --- a/sql/generics.lisp +++ b/sql/generics.lisp @@ -125,20 +125,8 @@ value. If nulls are allowed for the column, the slot's value will be nil, otherwise its value will be set to the result of calling DATABASE-NULL-VALUE on the type of the slot.")) -(defgeneric output-sql (expr database) - ) - -(defgeneric output-sql-hash-key (arg database) - ) - -(defgeneric collect-table-refs (sql) - ) -(defgeneric database-output-sql (arg database) - ) (defgeneric database-pkey-constraint (class database) ) -(defgeneric database-constraint-statement (constraints database) - ) (defgeneric %install-class (class database &key transactions) ) (defgeneric database-generate-column-definition (class slotdef database) @@ -154,3 +142,30 @@ DATABASE-NULL-VALUE on the type of the slot.")) (defgeneric read-sql-value (val type database db-type) ) + +;; Generation of SQL strings from lisp expressions + +(defgeneric output-sql (expr database) + (:documentation "Writes an SQL string appropriate for DATABASE + and corresponding to the lisp expression EXPR to + *SQL-STREAM*. The function SQL-OUTPUT is a top-level call for + generating SQL strings which initialises *SQL-STREAM*, calls + OUTPUT-SQL and reads the generated SQL string from + *SQL-STREAM*.")) + +(defgeneric database-output-sql (expr database) + (:documentation "Returns an SQL string appropriate for DATABASE + and corresponding to the lisp expression + EXPR. DATABASE-OUTPUT-SQL is called by OUTPUT-SQL when no more + specific method exists for EXPR.")) + +(defgeneric output-sql-hash-key (expr database) + (:documentation "Returns a list (or other object suitable for +use as the key of an EQUAL hash table) which uniquely identifies +the arguments EXPR and DATABASE.")) + +(defgeneric collect-table-refs (sql) + ) + +(defgeneric database-constraint-statement (constraints database) + ) diff --git a/sql/ooddl.lisp b/sql/ooddl.lisp index d44f022..3ec173a 100644 --- a/sql/ooddl.lisp +++ b/sql/ooddl.lisp @@ -108,8 +108,8 @@ in DATABASE which defaults to *DEFAULT-DATABASE*." (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)) + (sql-output (view-table class) database) + (sql-output keylist database)) database)))) (defmethod database-generate-column-definition (class slotdef database) -- 2.34.1