r10789: Automated commit for Debian build of clsql upstream-version-3.3.1

[clsql.git] / sql / expressions.lisp

diff --git a/sql/expressions.lisp b/sql/expressions.lisp
index 7f0ad1f82ff601a6556a8d45080fcb481494ba27..67fc6fa0b3c40a47312c8fd90e76c791f580e8a3 100644 (file)
--- a/sql/expressions.lisp
+++ b/sql/expressions.lisp
@@ -67,7 +67,8 @@
 (defmethod print-object ((self %sql-expression) stream)
   (print-unreadable-object
    (self stream :type t)
-   (write-string (sql-output self) stream)))
+   (write-string (sql-output self) stream))
+  self)
 
 ;; For straight up strings
 
@@ -91,7 +92,8 @@
 (defmethod print-object ((ident sql) stream)
   (format stream "#<~S \"~A\">"
           (type-of ident)
-          (sql-output ident nil)))
+          (sql-output ident nil))
+  ident)
 
 ;; For SQL Identifiers of generic type
 
@@ -196,14 +198,20 @@
     `(make-instance 'sql-ident-table :name ',name :table-alias ',alias)))
 
 (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))))
+  (with-slots (name alias) expr
+     (let ((namestr (if (symbolp name)
+                        (symbol-name name)
+                      name)))
+       (if (null alias)
+           (write-string
+            (sql-escape (convert-to-db-default-case namestr database))
+            *sql-stream*)
+         (progn
+           (write-string
+            (sql-escape (convert-to-db-default-case namestr database))
+            *sql-stream*)
+           (write-char #\Space *sql-stream*)
+           (format *sql-stream* "~s" alias)))))
   t)
 
 (defmethod output-sql-hash-key ((expr sql-ident-table) database)
@@ -221,6 +229,11 @@
     :initform nil))
   (:documentation "An SQL relational expression."))
 
+(defmethod make-load-form ((self sql-relational-exp) &optional environment)
+  (make-load-form-saving-slots self
+                               :slot-names '(operator sub-expressions)
+                               :environment environment))
+
 (defmethod collect-table-refs ((sql sql-relational-exp))
   (let ((tabs nil))
     (dolist (exp (slot-value sql 'sub-expressions))
@@ -354,7 +367,7 @@
 
 (defmethod collect-table-refs ((sql sql-function-exp))
   (let ((tabs nil))
-    (dolist (exp (slot-value sql 'components))
+    (dolist (exp (slot-value sql 'args))
       (let ((refs (collect-table-refs exp)))
         (if refs (setf tabs (append refs tabs)))))
     (remove-duplicates tabs
@@ -692,7 +705,7 @@ uninclusive, and the args from that keyword to the end."
     stmt
     (write-string "DELETE FROM " *sql-stream*)
     (typecase from
-      (symbol (write-string (sql-escape from) *sql-stream*))
+      ((or symbol string) (write-string (sql-escape from) *sql-stream*))
       (t  (output-sql from database)))
     (when where
       (write-string " WHERE " *sql-stream*)
@@ -828,9 +841,8 @@ uninclusive, and the args from that keyword to the end."
 ;; 
 
 (defmethod database-output-sql ((str string) database)
-  (declare (ignore database)
-           (optimize (speed 3) (safety 1) #+cmu (extensions:inhibit-warnings 3))
-           (type (simple-array * (*)) str))
+  (declare (optimize (speed 3) (safety 1)
+                    #+cmu (extensions:inhibit-warnings 3)))
   (let ((len (length str)))
     (declare (type fixnum len))
     (cond ((zerop len)
@@ -840,7 +852,8 @@ uninclusive, and the args from that keyword to the end."
            (concatenate 'string "'" str "'"))
           (t
            (let ((buf (make-string (+ (* len 2) 2) :initial-element #\')))
-             (do* ((i 0 (incf i))
+            (declare (simple-string buf))
+            (do* ((i 0 (incf i))
                    (j 1 (incf j)))
                   ((= i len) (subseq buf 0 (1+ j)))
                (declare (type fixnum i j))
@@ -850,7 +863,11 @@ uninclusive, and the args from that keyword to the end."
                         (setf (aref buf j) #\')
                         (incf j)
                         (setf (aref buf j) #\'))
-                       ((char= char #\\)
+                       ((and (char= char #\\)
+                             ;; MTP: only escape backslash with pgsql/mysql 
+                             (member (database-underlying-type database) 
+                                     '(:postgresql :mysql)
+                                     :test #'eq))
                         (setf (aref buf j) #\\)
                         (incf j)
                         (setf (aref buf j) #\\))
@@ -897,6 +914,10 @@ uninclusive, and the args from that keyword to the end."
   (declare (ignore database))
   (db-timestring self))
 
+(defmethod database-output-sql ((self date) database)
+  (declare (ignore database))
+  (db-datestring self))
+
 (defmethod database-output-sql ((self duration) database)
   (declare (ignore database))
   (format nil "'~a'" (duration-timestring self)))