From 6f9c91e01227e25e36560220628269258c80712d Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Mon, 16 Jan 2006 21:46:13 +0000 Subject: [PATCH] r10868: Automated commit for Debian build of clsql upstream-version-3.5.3 --- ChangeLog | 11 +++++ .../postgresql-socket-api.lisp | 12 ++++-- debian/changelog | 7 ++++ sql/database.lisp | 42 ++++++++++--------- sql/generic-postgresql.lisp | 34 +++++++-------- sql/pool.lisp | 3 +- sql/time.lisp | 15 ++++--- 7 files changed, 77 insertions(+), 47 deletions(-) diff --git a/ChangeLog b/ChangeLog index 975db54..f1c5868 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,14 @@ +16 Jan 2006 Kevin Rosenberg + * 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 * 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 66b2912..94d33f1 100644 --- 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 - (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 diff --git a/debian/changelog b/debian/changelog index 908ae6b..584cc67 100644 --- 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 Mon, 16 Jan 2006 14:43:55 -0700 + 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 285d3e2..faa384d 100644 --- a/sql/database.lisp +++ b/sql/database.lisp @@ -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))) diff --git a/sql/generic-postgresql.lisp b/sql/generic-postgresql.lisp index 983af78..aac16dd 100644 --- 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))) - (declare (ignore database db-type)) + (declare (ignore database)) (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) - (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))")) @@ -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-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) @@ -107,7 +107,7 @@ 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)) @@ -137,7 +137,7 @@ "oid" "ctid" ;; kmr -- added tableoid - "tableoid") :test #'equal)) + "tableoid") :test #'equal)) 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)) - + (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))))) -(defmethod database-sequence-next (sequence-name +(defmethod database-sequence-next (sequence-name (database generic-postgresql-database)) (values (parse-integer @@ -223,7 +223,7 @@ (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) @@ -235,13 +235,13 @@ (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' @@ -273,8 +273,8 @@ ((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) @@ -294,7 +294,7 @@ (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))))))) @@ -315,7 +315,7 @@ :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 diff --git a/sql/pool.lisp b/sql/pool.lisp index 587ad9d..6791a6e 100644 --- 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) - :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)) diff --git a/sql/time.lisp b/sql/time.lisp index 75f3faa..e045258 100644 --- 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) - (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))) -- 2.34.1