r10868: Automated commit for Debian build of clsql upstream-version-3.5.3
authorKevin M. Rosenberg <kevin@rosenberg.net>
Mon, 16 Jan 2006 21:46:13 +0000 (21:46 +0000)
committerKevin M. Rosenberg <kevin@rosenberg.net>
Mon, 16 Jan 2006 21:46:13 +0000 (21:46 +0000)
ChangeLog
db-postgresql-socket/postgresql-socket-api.lisp
debian/changelog
sql/database.lisp
sql/generic-postgresql.lisp
sql/pool.lisp
sql/time.lisp

index 975db54..f1c5868 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
index 66b2912..94d33f1 100644 (file)
@@ -334,10 +334,14 @@ socket interface"
   (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
index 908ae6b..584cc67 100644 (file)
@@ -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)
index 285d3e2..faa384d 100644 (file)
@@ -48,7 +48,7 @@ error is signalled."
     (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
@@ -91,18 +91,20 @@ be taken from this pool."
 
   (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)))
-  
+
   (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
-      (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
@@ -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
-    (destructuring-bind ,template ,connection-spec 
+    (destructuring-bind ,template ,connection-spec
       (declare (ignore ,@(remove '&optional template)))
       t)
-    (error () 
+    (error ()
      (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
@@ -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)))))
-                             
+
     (when (is-database-open db)
       (if force
          (ignore-errors (disconnect :database db))
          (disconnect :database db :error nil)))
-    
+
     (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
@@ -238,19 +240,19 @@ database is printed."
   (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)))
-                      (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")))
-                (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))))))
@@ -263,8 +265,8 @@ database is printed."
     (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)))
index 983af78..aac16dd 100644 (file)
@@ -51,7 +51,7 @@
 
 (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)))
 ;;; Backend functions
 
 (defun owner-clause (owner)
-  (cond 
+  (cond
    ((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))"))
 (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-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
-         (format 
+         (format
           nil
           "select indexrelid from pg_index where indrelid=(select relfilenode from pg_class where relname='~A'~A)"
           (string-downcase table)
          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))
                                                "oid"
                                                "ctid"
                                                ;; kmr -- added tableoid
-                                               "tableoid") :test #'equal)) 
+                                               "tableoid") :test #'equal))
                    result))))
 
 (defmethod database-attribute-type (attribute (table string)
 
         (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
       (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
       (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)
 (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.
-  (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'
     ((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)
          (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)))))))
                   :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
index 587ad9d..6791a6e 100644 (file)
@@ -37,7 +37,8 @@
             (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))
index 75f3faa..e045258 100644 (file)
@@ -1046,11 +1046,16 @@ with the given options"
   (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)))