r10868: Automated commit for Debian build of clsql upstream-version-3.5.3

diff --git a/ChangeLog b/ChangeLog
index 975db547d37804e79c2c211cc1bab47e04c70f45..f1c586829b1f3cd50c8d6c176b2c5465bd5ac508 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,14 @@
+16 Jan 2006  Kevin Rosenberg <kevin@rosenberg.net>
+       * Version 3.5.3
+       * sql/time.lisp: Commit patch from Aleksandar Bakic
+       to properly handle destructive flag
+       * db-postgresql-socket/postgresql-socket-api.lisp: Apply patch
+       from Steven Harris for socket files with SBCL.
+       * sql/pool.lisp: Apply patch from Vladimir Sekissov so that
+       new connections added to the pool do not become the *default-database*
+       * sql/connect.lisp: Optionally set *default-database* for pooled
+       connection when make-default is generalized true.
+       

 23 Dec 2005  Kevin Rosenberg <kevin@rosenberg.net>
        * Version 3.5.1
        * sql/expressions.lisp: Ensure table names are properly escaped
 23 Dec 2005  Kevin Rosenberg <kevin@rosenberg.net>
        * Version 3.5.1
        * sql/expressions.lisp: Ensure table names are properly escaped

diff --git a/db-postgresql-socket/postgresql-socket-api.lisp b/db-postgresql-socket/postgresql-socket-api.lisp
index 66b2912a9f84291e8124e612850ac7e88d972804..94d33f1d4c093b3ddf50cdfa3f12f1620f0a8489 100644 (file)
--- a/db-postgresql-socket/postgresql-socket-api.lisp
+++ b/db-postgresql-socket/postgresql-socket-api.lisp
@@ -334,10 +334,14 @@ socket interface"
   (etypecase host
     (pathname
      ;; Directory to unix-domain socket
   (etypecase host
     (pathname
      ;; Directory to unix-domain socket

-     (sb-bsd-sockets:socket-connect
-      (namestring
-       (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
-                     :defaults host))))
+     (let ((sock (make-instance 'sb-bsd-sockets:local-socket
+                               :type :stream)))
+       (sb-bsd-sockets:socket-connect
+        sock
+        (namestring
+         (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
+                        :defaults host)))
+       sock))

     (string
      (let ((sock (make-instance 'sb-bsd-sockets:inet-socket
                                :type :stream
     (string
      (let ((sock (make-instance 'sb-bsd-sockets:inet-socket
                                :type :stream

diff --git a/debian/changelog b/debian/changelog
index 908ae6bc05ebf3bb3d99e317cd1b2b6820fa14c4..584cc67b777e602a46b6fe232d21e725c384c8e1 100644 (file)
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,10 @@
+cl-sql (3.5.3-1) unstable; urgency=low
+
+  * New upstream
+  * Really commit patch for GNU/kFreeBSD (closes: 345219)
+
+ -- Kevin M. Rosenberg <kmr@debian.org>  Mon, 16 Jan 2006 14:43:55 -0700
+

 cl-sql (3.5.2-2) unstable; urgency=low
 
   * Commit patch for GNU/kFreeBSD (closes: 345219)
 cl-sql (3.5.2-2) unstable; urgency=low
 
   * Commit patch for GNU/kFreeBSD (closes: 345219)

diff --git a/sql/database.lisp b/sql/database.lisp
index 285d3e269b237e4d6817854465f7d01cfe78b035..faa384dd44a91013704b02dcdff4395ed5339bfb 100644 (file)
--- a/sql/database.lisp
+++ b/sql/database.lisp
@@ -48,7 +48,7 @@ error is signalled."
     (database
      (values database 1))
     (string
     (database
      (values database 1))
     (string

-     (let* ((matches (remove-if 
+     (let* ((matches (remove-if

                       #'(lambda (db)
                           (not (and (string= (database-name db) database)
                                     (if db-type
                       #'(lambda (db)
                           (not (and (string= (database-name db) database)
                                     (if db-type


@@ -91,18 +91,20 @@ be taken from this pool."
 
   (unless database-type
     (error 'sql-database-error :message "Must specify a database-type."))
 
   (unless database-type
     (error 'sql-database-error :message "Must specify a database-type."))

-  
+

   (when (stringp connection-spec)
     (setq connection-spec (string-to-list-connection-spec connection-spec)))
   (when (stringp connection-spec)
     (setq connection-spec (string-to-list-connection-spec connection-spec)))

-  
+

   (unless (member database-type *loaded-database-types*)
     (asdf:operate 'asdf:load-op (ensure-keyword
   (unless (member database-type *loaded-database-types*)
     (asdf:operate 'asdf:load-op (ensure-keyword

-                                (concatenate 'string 
+                                (concatenate 'string

                                              (symbol-name '#:clsql-)
                                              (symbol-name database-type)))))
 
   (if pool
                                              (symbol-name '#:clsql-)
                                              (symbol-name database-type)))))
 
   (if pool

-      (acquire-from-pool connection-spec database-type pool)
+      (let ((conn (acquire-from-pool connection-spec database-type pool)))
+        (when make-default (setq *default-database* conn))
+        conn)

       (let* ((db-name (database-name-from-spec connection-spec database-type))
              (old-db (unless (eq if-exists :new)
                        (find-database db-name :db-type database-type
       (let* ((db-name (database-name-from-spec connection-spec database-type))
              (old-db (unless (eq if-exists :new)
                        (find-database db-name :db-type database-type


@@ -185,13 +187,13 @@ from a pool it will be released to this pool."
 and signal an sql-user-error if they don't match. This function
 is called by database backends."
   `(handler-case
 and signal an sql-user-error if they don't match. This function
 is called by database backends."
   `(handler-case

-    (destructuring-bind ,template ,connection-spec 
+    (destructuring-bind ,template ,connection-spec

       (declare (ignore ,@(remove '&optional template)))
       t)
       (declare (ignore ,@(remove '&optional template)))
       t)

-    (error () 
+    (error ()

      (error 'sql-user-error
       :message
      (error 'sql-user-error
       :message

-      (format nil 
+      (format nil

              "The connection specification ~A~%is invalid for database type ~A.~%The connection specification must conform to ~A"
              ,connection-spec
              ,database-type
              "The connection specification ~A~%is invalid for database type ~A.~%The connection specification must conform to ~A"
              ,connection-spec
              ,database-type


@@ -221,15 +223,15 @@ database connection cannot be closed, an error is signalled."
                              (format nil "Unable to find database with connection-spec ~A." database))
                       (return-from reconnect nil)))
                 db)))))
                              (format nil "Unable to find database with connection-spec ~A." database))
                       (return-from reconnect nil)))
                 db)))))

-                             
+

     (when (is-database-open db)
       (if force
          (ignore-errors (disconnect :database db))
          (disconnect :database db :error nil)))
     (when (is-database-open db)
       (if force
          (ignore-errors (disconnect :database db))
          (disconnect :database db :error nil)))

-    
+

     (connect (connection-spec db))))
 
     (connect (connection-spec db))))
 

-  
+

 (defun status (&optional full)
   "Prints information about the currently connected databases to
 *STANDARD-OUTPUT*. The argument FULL is nil by default and a
 (defun status (&optional full)
   "Prints information about the currently connected databases to
 *STANDARD-OUTPUT*. The argument FULL is nil by default and a


@@ -238,19 +240,19 @@ database is printed."
   (flet ((get-data ()
            (let ((data '()))
              (dolist (db (connected-databases) data)
   (flet ((get-data ()
            (let ((data '()))
              (dolist (db (connected-databases) data)

-              (push 
-               (append 
-                (list (if (equal db *default-database*) "*" "")        
+              (push
+               (append
+                (list (if (equal db *default-database*) "*" "")

                       (database-name db)
                       (string-downcase (string (database-type db)))
                       (database-name db)
                       (string-downcase (string (database-type db)))

-                      (cond ((and (command-recording-stream db) 
-                                  (result-recording-stream db)) 
+                      (cond ((and (command-recording-stream db)
+                                  (result-recording-stream db))

                              "Both")
                             ((command-recording-stream db) "Commands")
                             ((result-recording-stream db) "Results")
                             (t "nil")))
                              "Both")
                             ((command-recording-stream db) "Commands")
                             ((result-recording-stream db) "Results")
                             (t "nil")))

-                (when full 
-                  (list 
+                (when full
+                  (list

                    (if (conn-pool db) "t" "nil")
                    (format nil "~A" (length (database-list-tables db)))
                    (format nil "~A" (length (database-list-views db))))))
                    (if (conn-pool db) "t" "nil")
                    (format nil "~A" (length (database-list-tables db)))
                    (format nil "~A" (length (database-list-views db))))))


@@ -263,8 +265,8 @@ database is printed."
     (format t "~&CLSQL STATUS: ~A~%" (iso-timestring (get-time)))
     (let ((data (get-data)))
       (when data
     (format t "~&CLSQL STATUS: ~A~%" (iso-timestring (get-time)))
     (let ((data (get-data)))
       (when data

-        (let* ((titles (if full 
-                          (list "" "DATABASE" "TYPE" "RECORDING" "POOLED" 
+        (let* ((titles (if full
+                          (list "" "DATABASE" "TYPE" "RECORDING" "POOLED"

                                 "TABLES" "VIEWS")
                           (list "" "DATABASE" "TYPE" "RECORDING")))
                (sizes (compute-sizes (cons titles data)))
                                 "TABLES" "VIEWS")
                           (list "" "DATABASE" "TYPE" "RECORDING")))
                (sizes (compute-sizes (cons titles data)))

diff --git a/sql/generic-postgresql.lisp b/sql/generic-postgresql.lisp
index 983af78b767025a496968f2e272e0e5c41b9563b..aac16ddc85acad1727bca12b56ce0028ce44c056 100644 (file)
--- a/sql/generic-postgresql.lisp
+++ b/sql/generic-postgresql.lisp
@@ -51,7 +51,7 @@
 
 (defmethod database-get-type-specifier ((type (eql 'number)) args database
                                         (db-type (eql :postgresql)))
 
 (defmethod database-get-type-specifier ((type (eql 'number)) args database
                                         (db-type (eql :postgresql)))

-  (declare (ignore database db-type))
+  (declare (ignore database))

   (cond
    ((and (consp args) (= (length args) 2))
     (format nil "NUMERIC(~D,~D)" (first args) (second args)))
   (cond
    ((and (consp args) (= (length args) 2))
     (format nil "NUMERIC(~D,~D)" (first args) (second args)))


@@ -63,11 +63,11 @@
 ;;; Backend functions
 
 (defun owner-clause (owner)
 ;;; Backend functions
 
 (defun owner-clause (owner)

-  (cond 
+  (cond

    ((stringp owner)
     (format
      nil
    ((stringp owner)
     (format
      nil

-     " AND (relowner=(SELECT usesysid FROM pg_user WHERE (usename='~A')))" 
+     " AND (relowner=(SELECT usesysid FROM pg_user WHERE (usename='~A')))"

      owner))
    ((null owner)
     (format nil " AND (NOT (relowner=1))"))
      owner))
    ((null owner)
     (format nil " AND (NOT (relowner=1))"))


@@ -85,11 +85,11 @@
 (defmethod database-list-tables ((database generic-postgresql-database)
                                  &key (owner nil))
   (database-list-objects-of-type database "r" owner))
 (defmethod database-list-tables ((database generic-postgresql-database)
                                  &key (owner nil))
   (database-list-objects-of-type database "r" owner))

-  
+

 (defmethod database-list-views ((database generic-postgresql-database)
                                 &key (owner nil))
   (database-list-objects-of-type database "v" owner))
 (defmethod database-list-views ((database generic-postgresql-database)
                                 &key (owner nil))
   (database-list-objects-of-type database "v" owner))

-  
+

 (defmethod database-list-indexes ((database generic-postgresql-database)
                                   &key (owner nil))
   (database-list-objects-of-type database "i" owner))
 (defmethod database-list-indexes ((database generic-postgresql-database)
                                   &key (owner nil))
   (database-list-objects-of-type database "i" owner))


@@ -99,7 +99,7 @@
                                        &key (owner nil))
   (let ((indexrelids
         (database-query
                                        &key (owner nil))
   (let ((indexrelids
         (database-query

-         (format 
+         (format

           nil
           "select indexrelid from pg_index where indrelid=(select relfilenode from pg_class where relname='~A'~A)"
           (string-downcase table)
           nil
           "select indexrelid from pg_index where indrelid=(select relfilenode from pg_class where relname='~A'~A)"
           (string-downcase table)


@@ -107,7 +107,7 @@
          database :auto nil))
        (result nil))
     (dolist (indexrelid indexrelids (nreverse result))
          database :auto nil))
        (result nil))
     (dolist (indexrelid indexrelids (nreverse result))

-      (push 
+      (push

        (caar (database-query
              (format nil "select relname from pg_class where relfilenode='~A'"
                      (car indexrelid))
        (caar (database-query
              (format nil "select relname from pg_class where relfilenode='~A'"
                      (car indexrelid))


@@ -137,7 +137,7 @@
                                                "oid"
                                                "ctid"
                                                ;; kmr -- added tableoid
                                                "oid"
                                                "ctid"
                                                ;; kmr -- added tableoid

-                                               "tableoid") :test #'equal)) 
+                                               "tableoid") :test #'equal))

                    result))))
 
 (defmethod database-attribute-type (attribute (table string)
                    result))))
 
 (defmethod database-attribute-type (attribute (table string)


@@ -154,7 +154,7 @@
 
         (setf attlen (parse-integer attlen :junk-allowed t)
               atttypmod (parse-integer atttypmod :junk-allowed t))
 
         (setf attlen (parse-integer attlen :junk-allowed t)
               atttypmod (parse-integer atttypmod :junk-allowed t))

-              
+

         (let ((coltype (ensure-keyword typname))
               (colnull (if (string-equal "f" attnull) 1 0))
               collen
         (let ((coltype (ensure-keyword typname))
               (colnull (if (string-equal "f" attnull) 1 0))
               collen


@@ -198,7 +198,7 @@
       (format nil "SELECT SETVAL ('~A', ~A)" name position)
       database nil nil)))))
 
       (format nil "SELECT SETVAL ('~A', ~A)" name position)
       database nil nil)))))
 

-(defmethod database-sequence-next (sequence-name 
+(defmethod database-sequence-next (sequence-name

                                   (database generic-postgresql-database))
   (values
    (parse-integer
                                   (database generic-postgresql-database))
   (values
    (parse-integer


@@ -223,7 +223,7 @@
       (unwind-protect
           (progn
             (setf (slot-value database 'clsql-sys::state) :open)
       (unwind-protect
           (progn
             (setf (slot-value database 'clsql-sys::state) :open)

-            (mapcar #'car (database-query "select datname from pg_database" 
+            (mapcar #'car (database-query "select datname from pg_database"

                                           database nil nil)))
        (progn
          (database-disconnect database)
                                           database nil nil)))
        (progn
          (database-disconnect database)


@@ -235,13 +235,13 @@
 (defmethod database-list (connection-spec (type (eql :postgresql-socket)))
   (postgresql-database-list connection-spec type))
 
 (defmethod database-list (connection-spec (type (eql :postgresql-socket)))
   (postgresql-database-list connection-spec type))
 

-#+nil 
+#+nil

 (defmethod database-describe-table ((database generic-postgresql-database) table)
   ;; MTP: LIST-ATTRIBUTE-TYPES currently executes separate queries for
   ;; each attribute. It would be more efficient to have a single SQL
   ;; query return the type data for all attributes. This code is
   ;; retained as an example of how to do this for PostgreSQL.
 (defmethod database-describe-table ((database generic-postgresql-database) table)
   ;; MTP: LIST-ATTRIBUTE-TYPES currently executes separate queries for
   ;; each attribute. It would be more efficient to have a single SQL
   ;; query return the type data for all attributes. This code is
   ;; retained as an example of how to do this for PostgreSQL.

-  (database-query 
+  (database-query

    (format nil "select a.attname, t.typname
                                from pg_class c, pg_attribute a, pg_type t
                                where c.relname = '~a'
    (format nil "select a.attname, t.typname
                                from pg_class c, pg_attribute a, pg_type t
                                where c.relname = '~a'


@@ -273,8 +273,8 @@
     ((in type :float :double :number) "NUMERIC")
     ((and (consp type) (in (car type) :char :varchar)) "VARCHAR")
     (t
     ((in type :float :double :number) "NUMERIC")
     ((and (consp type) (in (car type) :char :varchar)) "VARCHAR")
     (t

-     (error 'sql-user-error 
-           :message 
+     (error 'sql-user-error
+           :message

            (format nil "Unknown clsql type ~A." type)))))
 
 (defun prepared-sql-to-postgresql-sql (sql)
            (format nil "Unknown clsql type ~A." type)))))
 
 (defun prepared-sql-to-postgresql-sql (sql)


@@ -294,7 +294,7 @@
          (setq in-str (not in-str))
          (write-char c out))
         ((and (char= c #\?) (not in-str))
          (setq in-str (not in-str))
          (write-char c out))
         ((and (char= c #\?) (not in-str))

-         (write-char #\$ out) 
+         (write-char #\$ out)

          (write-string (write-to-string (incf param)) out))
         (t
          (write-char c out)))))))
          (write-string (write-to-string (incf param)) out))
         (t
          (write-char c out)))))))


@@ -315,7 +315,7 @@
                   :bindings (make-list (length types)))))
 
 (defmethod database-bind-parameter ((stmt postgresql-stmt) position value)
                   :bindings (make-list (length types)))))
 
 (defmethod database-bind-parameter ((stmt postgresql-stmt) position value)

-  (setf (nth (1- position) (bindings stmt)) value)) 
+  (setf (nth (1- position) (bindings stmt)) value))

 
 (defun binding-to-param (binding)
   (typecase binding
 
 (defun binding-to-param (binding)
   (typecase binding

diff --git a/sql/pool.lisp b/sql/pool.lisp
index 587ad9da953995b0675ed6dca0aec7d75c3400a0..6791a6e272368ad232d2318856248b743d74cd98 100644 (file)
--- a/sql/pool.lisp
+++ b/sql/pool.lisp
@@ -37,7 +37,8 @@
             (vector-pop (free-connections pool))))
       (let ((conn (connect (connection-spec pool)
                           :database-type (pool-database-type pool)
             (vector-pop (free-connections pool))))
       (let ((conn (connect (connection-spec pool)
                           :database-type (pool-database-type pool)

-                          :if-exists :new)))
+                          :if-exists :new
+                           :make-default nil)))

        (with-process-lock ((conn-pool-lock pool) "Acquire from pool")
          (vector-push-extend conn (all-connections pool))
          (setf (conn-pool conn) pool))
        (with-process-lock ((conn-pool-lock pool) "Acquire from pool")
          (vector-push-extend conn (all-connections pool))
          (setf (conn-pool conn) pool))

diff --git a/sql/time.lisp b/sql/time.lisp
index 75f3faafbc9cebef9af607acfa4fa3e35be30333..e04525889f54d301f4a428488d304e1cb37a7395 100644 (file)
--- a/sql/time.lisp
+++ b/sql/time.lisp
@@ -1046,11 +1046,16 @@ with the given options"
   (unless (= 0 year month)
     (multiple-value-bind (year-orig month-orig day-orig)
         (time-ymd date)
   (unless (= 0 year month)
     (multiple-value-bind (year-orig month-orig day-orig)
         (time-ymd date)

-      (setf date (make-time :year (+ year year-orig)
-                            :month (+ month month-orig)
-                            :day day-orig
-                            :second (time-second date)
-                            :usec usec))))
+      (multiple-value-bind (new-year new-month)
+         (floor (+ month month-orig (* 12 (+ year year-orig))) 12)
+       (let ((new-date (make-time :year new-year
+                                  :month new-month
+                                  :day day-orig
+                                  :second (time-second date)
+                                  :usec usec)))
+         (if destructive
+             (setf (time-mjd date) (time-mjd new-date))
+             (setq date new-date))))))

   (let ((mjd (time-mjd date))
         (sec (time-second date))
         (usec (time-usec date)))
   (let ((mjd (time-mjd date))
         (sec (time-second date))
         (usec (time-usec date)))