;;;;
;;;; Name: postgresql-socket-api.lisp
;;;; Purpose: Low-level PostgreSQL interface using sockets
-;;;; Authors: Kevin M. Rosenberg based on original code by Pierre R. Mai
+;;;; Authors: Kevin M. Rosenberg based on original code by Pierre R. Mai
;;;; Created: Feb 2002
;;;;
-;;;; $Id$
-;;;;
-;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg
+;;;; This file, part of CLSQL, is Copyright (c) 2002-2010 by Kevin M. Rosenberg
;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
;;;;
;;;; CLSQL users are granted the rights to distribute and use this software
(in-package #:postgresql-socket)
+;; KMR: 2011-06-12
+;; FIXME: The file has code specific to sb-unicode and CCL
+;; to assume UTF8 encoded strings.
+;; Best fix would be to use the user-specified encoding that is now
+;; stored in the database object and use the UFFI 2.x encoding functions
+;; to convert strings to/from octet vectors. This allows encoding
+;; other than UTF8 and also works on all CL implementations that
+;; support wide character strings
+
(uffi:def-enum pgsql-ftype
((:bytea 17)
(:int2 21)
(:float8 701)))
(defmethod clsql-sys:database-type-library-loaded ((database-type
- (eql :postgresql-socket)))
+ (eql :postgresql-socket)))
"T if foreign library was able to be loaded successfully. Always true for
socket interface"
t)
(defmacro define-message-constants (description &rest clauses)
(assert (evenp (length clauses)))
(loop with seen-characters = nil
- for (name char) on clauses by #'cddr
- for char-code = (char-code char)
- for doc-string = (format nil "~A (~:C): ~A" description char name)
- if (member char seen-characters)
- do (error "Duplicate message type ~@C for group ~A" char description)
- else
- collect
- `(defconstant ,name ,char-code ,doc-string)
- into result-clauses
- and do (push char seen-characters)
+ for (name char) on clauses by #'cddr
+ for char-code = (char-code char)
+ for doc-string = (format nil "~A (~:C): ~A" description char name)
+ if (member char seen-characters)
+ do (error "Duplicate message type ~@C for group ~A" char description)
+ else
+ collect
+ `(defconstant ,name ,char-code ,doc-string)
+ into result-clauses
+ and do (push char seen-characters)
finally
- (return `(progn ,@result-clauses))))
+ (return `(progn ,@result-clauses))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(define-message-constants "Backend Message Constants"
(defun send-socket-value-int32 (socket value)
(declare (type stream socket)
- (type (unsigned-byte 32) value))
+ (type (unsigned-byte 32) value))
(write-byte (ldb (byte 8 24) value) socket)
(write-byte (ldb (byte 8 16) value) socket)
(write-byte (ldb (byte 8 8) value) socket)
(defun send-socket-value-int16 (socket value)
(declare (type stream socket)
- (type (unsigned-byte 16) value))
+ (type (unsigned-byte 16) value))
(write-byte (ldb (byte 8 8) value) socket)
(write-byte (ldb (byte 8 0) value) socket)
nil)
(defun send-socket-value-int8 (socket value)
(declare (type stream socket)
- (type (unsigned-byte 8) value))
+ (type (unsigned-byte 8) value))
(write-byte (ldb (byte 8 0) value) socket)
nil)
(defun send-socket-value-char-code (socket value)
(declare (type stream socket)
- (type character value))
+ (type character value))
(write-byte (ldb (byte 8 0) (char-code value)) socket)
nil)
(defun send-socket-value-string (socket value)
(declare (type stream socket)
- (type string value))
+ (type string value))
+ #-(or sb-unicode ccl)
(loop for char across value
- for code = (char-code char)
- do (write-byte code socket)
- finally (write-byte 0 socket))
+ for code = (char-code char)
+ do (write-byte code socket)
+ finally (write-byte 0 socket))
+ #+ccl
+ (write-sequence (ccl:encode-string-to-octets
+ value :external-format :utf-8) socket)
+ #+ccl
+ (write-byte 0 socket)
+ #+sb-unicode
+ (write-sequence (sb-ext:string-to-octets value :null-terminate t)
+ socket)
nil)
(defun send-socket-value-limstring (socket value limit)
(declare (type stream socket)
- (type string value)
- (type fixnum limit))
+ (type string value)
+ (type fixnum limit))
(let ((length (length value)))
(dotimes (i (min length limit))
(let ((code (char-code (char value i))))
- (write-byte code socket)))
+ (write-byte code socket)))
(dotimes (i (- limit length))
(write-byte 0 socket)))
nil)
(declare (type stream socket))
(read-byte socket))
+
(defun read-socket-value-string (socket)
(declare (type stream socket))
+ #-(or sb-unicode ccl)
(with-output-to-string (out)
(loop for code = (read-byte socket)
- until (zerop code)
- do (write-char (code-char code) out))))
-
+ until (zerop code)
+ do (write-char (code-char code) out)))
+ #+ccl
+ (let ((bytes (make-array 64
+ :element-type '(unsigned-byte 8)
+ :adjustable t
+ :fill-pointer 0)))
+ (loop for code = (read-byte socket)
+ until (zerop code)
+ do (vector-push-extend code bytes))
+ (ccl:decode-string-from-octets bytes :external-format :utf-8))
+ #+sb-unicode
+ (let ((bytes (make-array 64
+ :element-type '(unsigned-byte 8)
+ :adjustable t
+ :fill-pointer 0)))
+ (loop for code = (read-byte socket)
+ until (zerop code)
+ do (vector-push-extend code bytes))
+ (sb-ext:octets-to-string bytes)))
(defmacro define-message-sender (name (&rest args) &rest clauses)
(let ((socket-var (gensym))
- (body nil))
+ (body nil))
(dolist (clause clauses)
(let* ((type (first clause))
- (fn (intern (concatenate 'string (symbol-name '#:send-socket-value-)
- (symbol-name type)))))
- (push `(,fn ,socket-var ,@(rest clause)) body)))
+ (fn (intern (concatenate 'string (symbol-name '#:send-socket-value-)
+ (symbol-name type)))))
+ (push `(,fn ,socket-var ,@(rest clause)) body)))
`(defun ,name (,socket-var ,@args)
,@(nreverse body))))
(int32 pid)
(int32 key))
+(defun read-bytes (socket length)
+ "Read a byte array of the given length from a stream."
+ (declare (type stream socket)
+ (type fixnum length)
+ (optimize (speed 3) (safety 0)))
+ (let ((result (make-array length :element-type '(unsigned-byte 8))))
+ (read-sequence result socket)
+ result))
-(defun read-socket-sequence (string stream)
- "KMR -- Added to support reading from binary stream into a string"
- (declare (string string)
- (stream stream)
- (optimize (speed 3) (safety 0)))
- (dotimes (i (length string))
- (declare (fixnum i))
- (setf (char string i) (code-char (read-byte stream))))
- string)
-
+(defun read-socket-sequence (stream length &optional (allow-wide t))
+ (declare (stream stream)
+ (optimize (speed 3) (safety 0)))
+ #-(or sb-unicode ccl)
+ (let ((result (make-string length)))
+ (dotimes (i length result)
+ (declare (fixnum i))
+ (setf (char result i) (code-char (read-byte stream)))))
+ #+ccl
+ (let ((bytes (make-array length :element-type '(unsigned-byte 8))))
+ (declare (type (simple-array (unsigned-byte 8) (*)) bytes))
+ (read-sequence bytes stream)
+ (if allow-wide
+ (ccl:decode-string-from-octets bytes :external-format :utf-8)
+ (map 'string #'code-char bytes)))
+ #+sb-unicode
+ (let ((bytes (make-array length :element-type '(unsigned-byte 8))))
+ (declare (type (simple-array (unsigned-byte 8) (*)) bytes))
+ (read-sequence bytes stream)
+ (if allow-wide
+ (sb-ext:octets-to-string bytes)
+ (map 'string #'code-char bytes))))
;;; Support for encrypted password transmission
(defvar *crypt-library-loaded* nil)
(unless *crypt-library-loaded*
- (uffi:load-foreign-library
+ (uffi:load-foreign-library
(uffi:find-foreign-library "libcrypt"
- '(#+64bit "/usr/lib64/"
- "/usr/lib/" "/usr/local/lib/" "/lib/"))
+ '(#+(or 64bit x86-64) "/usr/lib64/"
+ "/usr/lib/" "/usr/local/lib/" "/lib/"))
:supporting-libraries '("c"))
(setq *crypt-library-loaded* t)))
"Encrypt a password for transmission to a PostgreSQL server."
(uffi:with-cstring (password-cstring password)
(uffi:with-cstring (salt-cstring salt)
- (uffi:convert-from-cstring
+ (uffi:convert-from-cstring
(crypt password-cstring salt-cstring)))))
\f
(:report
(lambda (c stream)
(format stream "~@<~A occurred on connection ~A. ~:@_Reason: ~A~:@>"
- (type-of c)
- (postgresql-condition-connection c)
- (postgresql-condition-message c)))))
+ (type-of c)
+ (postgresql-condition-connection c)
+ (postgresql-condition-message c)))))
(define-condition postgresql-error (error postgresql-condition)
())
(:report
(lambda (c stream)
(format stream "~@<Asynchronous notification on connection ~A: ~:@_~A~:@>"
- (postgresql-condition-connection c)
- (postgresql-condition-message c)))))
+ (postgresql-condition-connection c)
+ (postgresql-condition-message c)))))
;;; Structures
(ext:connect-to-unix-socket
(namestring
(make-pathname :name ".s.PGSQL" :type (princ-to-string port)
- :defaults host))))
+ :defaults host))))
(string
(ext:connect-to-inet-socket host port))))
(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
- :protocol :tcp)))
- (sb-bsd-sockets:socket-connect
- sock
- (sb-bsd-sockets:host-ent-address
- (sb-bsd-sockets:get-host-by-name host))
- port)
+ :type :stream
+ :protocol :tcp)))
+ (sb-bsd-sockets:socket-connect
+ sock
+ (sb-bsd-sockets:host-ent-address
+ (sb-bsd-sockets:get-host-by-name host))
+ port)
sock))))
#+(or cmu scl)
#+sbcl
(defun open-postgresql-socket-stream (host port)
(sb-bsd-sockets:socket-make-stream
- (open-postgresql-socket host port) :input t :output t
+ (open-postgresql-socket host port) :input t :output t
:element-type '(unsigned-byte 8)))
-
+
#+allegro
(defun open-postgresql-socket-stream (host port)
(etypecase host
(pathname
(let ((path (namestring
- (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
- :defaults host))))
+ (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
+ :defaults host))))
(socket:make-socket :type :stream :address-family :file
- :connect :active
- :remote-filename path :local-filename path)))
+ :connect :active
+ :remote-filename path :local-filename path)))
(string
(socket:with-pending-connect
- (mp:with-timeout (*postgresql-server-socket-timeout* (error "connect failed"))
- (socket:make-socket :type :stream :address-family :internet
- :remote-port port :remote-host host
- :connect :active :nodelay t))))))
+ (mp:with-timeout (*postgresql-server-socket-timeout* (error "connect failed"))
+ (socket:make-socket :type :stream :address-family :internet
+ :remote-port port :remote-host host
+ :connect :active :nodelay t))))))
#+openmcl
(defun open-postgresql-socket-stream (host port)
(etypecase host
(pathname
(let ((path (namestring
- (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
- :defaults host))))
+ (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
+ :defaults host))))
(ccl:make-socket :type :stream :address-family :file
- :connect :active
- :remote-filename path :local-filename path)))
+ :connect :active
+ :remote-filename path :local-filename path)))
(string
(ccl:make-socket :type :stream :address-family :internet
- :remote-port port :remote-host host
- :connect :active :nodelay t))))
+ :remote-port port :remote-host host
+ :connect :active :nodelay t))))
#+lispworks
(defun open-postgresql-socket-stream (host port)
(error "File sockets not supported on Lispworks."))
(string
(comm:open-tcp-stream host port :direction :io :element-type '(unsigned-byte 8)
- :read-timeout *postgresql-server-socket-timeout*))
+ :read-timeout *postgresql-server-socket-timeout*))
))
+
+#+clisp
+(defun open-postgresql-socket-stream (host port)
+ (etypecase host
+ (pathname
+ (error "Not supported"))
+ (string
+ (socket:socket-connect
+ port host
+ :element-type '(unsigned-byte 8)
+ :timeout *postgresql-server-socket-timeout*))))
+
+
;;; Interface Functions
(defun open-postgresql-connection (&key (host (cmucl-compat:required-argument))
- (port +postgresql-server-default-port+)
- (database (cmucl-compat:required-argument))
- (user (cmucl-compat:required-argument))
- options tty password)
+ (port +postgresql-server-default-port+)
+ (database (cmucl-compat:required-argument))
+ (user (cmucl-compat:required-argument))
+ options tty password)
"Open a connection to a PostgreSQL server with the given parameters.
Note that host, database and user arguments must be supplied.
troubles."
(reopen-postgresql-connection
(make-postgresql-connection :host host :port port
- :options (or options "") :tty (or tty "")
- :database database :user user
- :password (or password ""))))
+ :options (or options "") :tty (or tty "")
+ :database database :user user
+ :password (or password ""))))
-(defun encrypt-md5 (plaintext salt)
- (string-downcase
- (format nil "~{~2,'0X~}"
- (coerce (md5:md5sum-sequence (concatenate 'string plaintext salt)) 'list))))
+(defun byte-sequence-to-hex-string (sequence)
+ (string-downcase (format nil "~{~2,'0X~}" (coerce sequence 'list))))
+
+(defun encrypt-password-md5 (password user salt)
+ (let ((pass1 (byte-sequence-to-hex-string
+ (md5::md5sum-string (concatenate 'string password user)))))
+ (byte-sequence-to-hex-string
+ (md5:md5sum-sequence (concatenate '(vector (unsigned-byte 8))
+ (map '(vector (unsigned-byte 8)) #'char-code pass1)
+ salt)))))
(defun reopen-postgresql-connection (connection)
"Reopen the given PostgreSQL connection. Closes any existing
connection, if it is still open."
(when (postgresql-connection-open-p connection)
(close-postgresql-connection connection))
- (let ((socket (open-postgresql-socket-stream
- (postgresql-connection-host connection)
- (postgresql-connection-port connection))))
+ (let ((socket (open-postgresql-socket-stream
+ (postgresql-connection-host connection)
+ (postgresql-connection-port connection))))
(unwind-protect
- (progn
- (setf (postgresql-connection-socket connection) socket)
- (send-startup-message socket
- (postgresql-connection-database connection)
- (postgresql-connection-user connection)
- (postgresql-connection-options connection)
- (postgresql-connection-tty connection))
- (force-output socket)
- (loop
- (case (read-socket-value-int8 socket)
- (#.+authentication-message+
- (case (read-socket-value-int32 socket)
- (0 (return))
- ((1 2)
- (error 'postgresql-login-error
- :connection connection
- :message
- "Postmaster expects unsupported Kerberos authentication."))
- (3
- (send-unencrypted-password-message
- socket
- (postgresql-connection-password connection)))
- (4
- (let ((salt (make-string 2)))
- (read-socket-sequence salt socket)
- (send-encrypted-password-message
- socket
- (crypt-password
- (postgresql-connection-password connection) salt))))
- (5
- (let ((salt (make-string 4)))
- (read-socket-sequence salt socket)
- (let* ((pwd2 (encrypt-md5 (postgresql-connection-password connection)
- (postgresql-connection-user connection)))
- (pwd (encrypt-md5 pwd2 salt)))
- (send-encrypted-password-message
- socket
- (concatenate 'string "md5" pwd)))))
- (t
- (error 'postgresql-login-error
- :connection connection
- :message
- "Postmaster expects unknown authentication method."))))
- (#.+error-response-message+
- (let ((message (read-socket-value-string socket)))
- (error 'postgresql-login-error
- :connection connection :message message)))
- (t
- (error 'postgresql-login-error
- :connection connection
- :message
- "Received garbled message from Postmaster"))))
- ;; Start backend communication
- (force-output socket)
- (loop
- (case (read-socket-value-int8 socket)
- (#.+backend-key-message+
- (setf (postgresql-connection-pid connection)
- (read-socket-value-int32 socket)
- (postgresql-connection-key connection)
- (read-socket-value-int32 socket)))
- (#.+ready-for-query-message+
- (setq socket nil)
- (return connection))
- (#.+error-response-message+
- (let ((message (read-socket-value-string socket)))
- (error 'postgresql-login-error
- :connection connection
- :message message)))
- (#.+notice-response-message+
- (let ((message (read-socket-value-string socket)))
- (warn 'postgresql-warning :connection connection
- :message message)))
- (t
- (error 'postgresql-login-error
- :connection connection
- :message
- "Received garbled message from Postmaster")))))
+ (progn
+ (setf (postgresql-connection-socket connection) socket)
+ (send-startup-message socket
+ (postgresql-connection-database connection)
+ (postgresql-connection-user connection)
+ (postgresql-connection-options connection)
+ (postgresql-connection-tty connection))
+ (force-output socket)
+ (loop
+ (case (read-socket-value-int8 socket)
+ (#.+authentication-message+
+ (case (read-socket-value-int32 socket)
+ (0 (return))
+ ((1 2)
+ (error 'postgresql-login-error
+ :connection connection
+ :message
+ "Postmaster expects unsupported Kerberos authentication."))
+ (3
+ (send-unencrypted-password-message
+ socket
+ (postgresql-connection-password connection))
+ (force-output socket))
+ (4
+ (let ((salt (read-socket-sequence socket 2 nil)))
+ (send-encrypted-password-message
+ socket
+ (crypt-password
+ (postgresql-connection-password connection) salt)))
+ (force-output socket))
+ (5
+ (let ((salt (read-bytes socket 4)))
+ (let ((pwd (encrypt-password-md5
+ (postgresql-connection-password connection)
+ (postgresql-connection-user connection)
+ salt)))
+ (send-encrypted-password-message
+ socket
+ (concatenate 'string "md5" pwd))))
+ (force-output socket))
+ (t
+ (error 'postgresql-login-error
+ :connection connection
+ :message
+ "Postmaster expects unknown authentication method."))))
+ (#.+error-response-message+
+ (let ((message (read-socket-value-string socket)))
+ (error 'postgresql-login-error
+ :connection connection :message message)))
+ (t
+ (error 'postgresql-login-error
+ :connection connection
+ :message
+ "Received garbled message from Postmaster"))))
+ ;; Start backend communication
+ (force-output socket)
+ (loop
+ (case (read-socket-value-int8 socket)
+ (#.+backend-key-message+
+ (setf (postgresql-connection-pid connection)
+ (read-socket-value-int32 socket)
+ (postgresql-connection-key connection)
+ (read-socket-value-int32 socket)))
+ (#.+ready-for-query-message+
+ (setq socket nil)
+ (return connection))
+ (#.+error-response-message+
+ (let ((message (read-socket-value-string socket)))
+ (error 'postgresql-login-error
+ :connection connection
+ :message message)))
+ (#.+notice-response-message+
+ (let ((message (read-socket-value-string socket)))
+ (warn 'postgresql-warning :connection connection
+ :message message)))
+ (t
+ (error 'postgresql-login-error
+ :connection connection
+ :message
+ "Received garbled message from Postmaster")))))
(when socket
- (close socket)))))
+ (close socket)))))
(defun close-postgresql-connection (connection &optional abort)
(unless abort
(assert (postgresql-connection-open-p connection))
;; Process any asnychronous messages
(loop with socket = (postgresql-connection-socket connection)
- while (listen socket)
- do
- (case (read-socket-value-int8 socket)
- (#.+notice-response-message+
- (let ((message (read-socket-value-string socket)))
- (warn 'postgresql-warning :connection connection
- :message message)))
- (#.+notification-response-message+
- (let ((pid (read-socket-value-int32 socket))
- (message (read-socket-value-string socket)))
- (when (= pid (postgresql-connection-pid connection))
- (signal 'postgresql-notification :connection connection
- :message message))))
- (t
- (close-postgresql-connection connection)
- (error 'postgresql-fatal-error :connection connection
- :message "Received garbled message from backend")))))
+ while (listen socket)
+ do
+ (case (read-socket-value-int8 socket)
+ (#.+ready-for-query-message+)
+ (#.+notice-response-message+
+ (let ((message (read-socket-value-string socket)))
+ (warn 'postgresql-warning :connection connection
+ :message message)))
+ (#.+notification-response-message+
+ (let ((pid (read-socket-value-int32 socket))
+ (message (read-socket-value-string socket)))
+ (when (= pid (postgresql-connection-pid connection))
+ (signal 'postgresql-notification :connection connection
+ :message message))))
+ (t
+ (close-postgresql-connection connection)
+ (error 'postgresql-fatal-error :connection connection
+ :message "Received garbled message from backend")))))
(defun start-query-execution (connection query)
(ensure-open-postgresql-connection connection)
(defun wait-for-query-results (connection)
(assert (postgresql-connection-open-p connection))
(let ((socket (postgresql-connection-socket connection))
- (cursor-name nil)
- (error nil))
+ (cursor-name nil)
+ (error nil))
(loop
- (case (read-socket-value-int8 socket)
- (#.+completed-response-message+
- (return (values :completed (read-socket-value-string socket))))
- (#.+cursor-response-message+
- (setq cursor-name (read-socket-value-string socket)))
- (#.+row-description-message+
- (let* ((count (read-socket-value-int16 socket))
- (fields
- (loop repeat count
- collect
- (list
- (read-socket-value-string socket)
- (read-socket-value-int32 socket)
- (read-socket-value-int16 socket)
- (read-socket-value-int32 socket)))))
- (return
- (values :cursor
- (make-postgresql-cursor :connection connection
- :name cursor-name
- :fields fields)))))
- (#.+copy-in-response-message+
- (return :copy-in))
- (#.+copy-out-response-message+
- (return :copy-out))
- (#.+ready-for-query-message+
- (when error
- (error error))
- (return nil))
- (#.+error-response-message+
- (let ((message (read-socket-value-string socket)))
- (setq error
- (make-condition 'postgresql-error
- :connection connection :message message))))
- (#.+notice-response-message+
- (let ((message (read-socket-value-string socket)))
- (unless (eq :ignore clsql-sys:*backend-warning-behavior*)
- (warn 'postgresql-warning
- :connection connection :message message))))
- (#.+notification-response-message+
- (let ((pid (read-socket-value-int32 socket))
- (message (read-socket-value-string socket)))
- (when (= pid (postgresql-connection-pid connection))
- (signal 'postgresql-notification :connection connection
- :message message))))
- (t
- (close-postgresql-connection connection)
- (error 'postgresql-fatal-error :connection connection
- :message "Received garbled message from backend"))))))
+ (case (read-socket-value-int8 socket)
+ (#.+completed-response-message+
+ (return (values :completed (read-socket-value-string socket))))
+ (#.+cursor-response-message+
+ (setq cursor-name (read-socket-value-string socket)))
+ (#.+row-description-message+
+ (let* ((count (read-socket-value-int16 socket))
+ (fields
+ (loop repeat count
+ collect
+ (list
+ (read-socket-value-string socket)
+ (read-socket-value-int32 socket)
+ (read-socket-value-int16 socket)
+ (read-socket-value-int32 socket)))))
+ (return
+ (values :cursor
+ (make-postgresql-cursor :connection connection
+ :name cursor-name
+ :fields fields)))))
+ (#.+copy-in-response-message+
+ (return :copy-in))
+ (#.+copy-out-response-message+
+ (return :copy-out))
+ (#.+ready-for-query-message+
+ (when error
+ (error error))
+ (return nil))
+ (#.+error-response-message+
+ (let ((message (read-socket-value-string socket)))
+ (setq error
+ (make-condition 'postgresql-error
+ :connection connection :message message))))
+ (#.+notice-response-message+
+ (let ((message (read-socket-value-string socket)))
+ (unless (eq :ignore clsql-sys:*backend-warning-behavior*)
+ (warn 'postgresql-warning
+ :connection connection :message message))))
+ (#.+notification-response-message+
+ (let ((pid (read-socket-value-int32 socket))
+ (message (read-socket-value-string socket)))
+ (when (= pid (postgresql-connection-pid connection))
+ (signal 'postgresql-notification :connection connection
+ :message message))))
+ (t
+ (close-postgresql-connection connection)
+ (error 'postgresql-fatal-error :connection connection
+ :message "Received garbled message from backend"))))))
(defun read-null-bit-vector (socket count)
(let ((result (make-array count :element-type 'bit)))
(dotimes (offset (ceiling count 8))
(loop with byte = (read-byte socket)
- for index from (* offset 8) below (min count (* (1+ offset) 8))
- for weight downfrom 7
- do (setf (aref result index) (ldb (byte 1 weight) byte))))
+ for index from (* offset 8) below (min count (* (1+ offset) 8))
+ for weight downfrom 7
+ do (setf (aref result index) (ldb (byte 1 weight) byte))))
result))
(:double
(read-double-from-socket socket length))
(t
- (let ((result (make-string length)))
- (read-socket-sequence result socket)
- result)))))
+ (read-socket-sequence socket length)))))
(uffi:def-constant +char-code-zero+ (char-code #\0))
(uffi:def-constant +char-code-minus+ (char-code #\-))
(if (zerop length)
nil
(let ((val 0)
- (first-char (read-byte socket))
- (minusp nil))
+ (first-char (read-byte socket))
+ (minusp nil))
(declare (fixnum first-char))
(decf length) ;; read first char
(cond
((= first-char +char-code-minus+)
- (setq minusp t))
+ (setq minusp t))
((= first-char +char-code-plus+)
- ) ;; nothing to do
+ ) ;; nothing to do
(t
- (setq val (- first-char +char-code-zero+))))
-
+ (setq val (- first-char +char-code-zero+))))
+
(dotimes (i length)
- (declare (fixnum i))
- (setq val (+
- (* 10 val)
- (- (read-byte socket) +char-code-zero+))))
+ (declare (fixnum i))
+ (setq val (+
+ (* 10 val)
+ (- (read-byte socket) +char-code-zero+))))
(if minusp
- (- val)
- val))))
+ (- val)
+ val))))
(defmacro ascii-digit (int)
(let ((offset (gensym)))
`(let ((,offset (- ,int +char-code-zero+)))
(declare (fixnum ,int ,offset))
(if (and (>= ,offset 0)
- (< ,offset 10))
- ,offset
- nil))))
-
+ (< ,offset 10))
+ ,offset
+ nil))))
+
(defun read-double-from-socket (socket length)
(declare (fixnum length))
(let ((before-decimal 0)
- (after-decimal 0)
- (decimal-count 0)
- (exponent 0)
- (decimalp nil)
- (minusp nil)
- (result nil)
- (char (read-byte socket)))
+ (after-decimal 0)
+ (decimal-count 0)
+ (exponent 0)
+ (decimalp nil)
+ (minusp nil)
+ (result nil)
+ (char (read-byte socket)))
(declare (fixnum char exponent decimal-count))
(decf length) ;; already read first character
(cond
(t
(setq before-decimal (ascii-digit char))
(unless before-decimal
- (error "Unexpected value"))))
-
+ (error "Unexpected value"))))
+
(block loop
(dotimes (i length)
- (setq char (read-byte socket))
- ;; (format t "~&len:~D, i:~D, char:~D, minusp:~A, decimalp:~A" length i char minusp decimalp)
- (let ((weight (ascii-digit char)))
- (cond
- ((and weight (not decimalp)) ;; before decimal point
- (setq before-decimal (+ weight (* 10 before-decimal))))
- ((and weight decimalp) ;; after decimal point
- (setq after-decimal (+ weight (* 10 after-decimal)))
- (incf decimal-count))
- ((and (= char +char-code-period+))
- (setq decimalp t))
- ((or (= char +char-code-lower-e+) ;; E is for exponent
- (= char +char-code-upper-e+))
- (setq exponent (read-integer-from-socket socket (- length i 1)))
- (setq exponent (or exponent 0))
- (return-from loop))
- (t
- (break "Unexpected value"))
- )
- )))
+ (setq char (read-byte socket))
+ ;; (format t "~&len:~D, i:~D, char:~D, minusp:~A, decimalp:~A" length i char minusp decimalp)
+ (let ((weight (ascii-digit char)))
+ (cond
+ ((and weight (not decimalp)) ;; before decimal point
+ (setq before-decimal (+ weight (* 10 before-decimal))))
+ ((and weight decimalp) ;; after decimal point
+ (setq after-decimal (+ weight (* 10 after-decimal)))
+ (incf decimal-count))
+ ((and (= char +char-code-period+))
+ (setq decimalp t))
+ ((or (= char +char-code-lower-e+) ;; E is for exponent
+ (= char +char-code-upper-e+))
+ (setq exponent (read-integer-from-socket socket (- length i 1)))
+ (setq exponent (or exponent 0))
+ (return-from loop))
+ (t
+ (break "Unexpected value"))
+ )
+ )))
(setq result (* (+ (coerce before-decimal 'double-float)
- (* after-decimal
- (expt 10 (- decimal-count))))
- (expt 10 exponent)))
+ (* after-decimal
+ (expt 10 (- decimal-count))))
+ (expt 10 exponent)))
(if minusp
- (- result)
- result)))
-
-
+ (- result)
+ result)))
+
+
#+ignore
(defun read-double-from-socket (socket length)
(let ((result (make-string length)))
(defun read-cursor-row (cursor types)
(let* ((connection (postgresql-cursor-connection cursor))
- (socket (postgresql-connection-socket connection))
- (fields (postgresql-cursor-fields cursor)))
+ (socket (postgresql-connection-socket connection))
+ (fields (postgresql-cursor-fields cursor)))
(assert (postgresql-connection-open-p connection))
(loop
- (let ((code (read-socket-value-int8 socket)))
- (case code
- (#.+ascii-row-message+
- (return
- (loop with count = (length fields)
- with null-vector = (read-null-bit-vector socket count)
- repeat count
- for null-bit across null-vector
- for i from 0
- for null-p = (zerop null-bit)
- if null-p
- collect nil
- else
- collect
- (read-field socket (nth i types)))))
- (#.+binary-row-message+
- (error "NYI"))
- (#.+completed-response-message+
- (return (values nil (read-socket-value-string socket))))
- (#.+error-response-message+
- (let ((message (read-socket-value-string socket)))
- (error 'postgresql-error
- :connection connection :message message)))
- (#.+notice-response-message+
- (let ((message (read-socket-value-string socket)))
- (warn 'postgresql-warning
- :connection connection :message message)))
- (#.+notification-response-message+
- (let ((pid (read-socket-value-int32 socket))
- (message (read-socket-value-string socket)))
- (when (= pid (postgresql-connection-pid connection))
- (signal 'postgresql-notification :connection connection
- :message message))))
- (t
- (close-postgresql-connection connection)
- (error 'postgresql-fatal-error :connection connection
- :message "Received garbled message from backend")))))))
+ (let ((code (read-socket-value-int8 socket)))
+ (case code
+ (#.+ascii-row-message+
+ (return
+ (loop with count = (length fields)
+ with null-vector = (read-null-bit-vector socket count)
+ repeat count
+ for null-bit across null-vector
+ for i from 0
+ for null-p = (zerop null-bit)
+ if null-p
+ collect nil
+ else
+ collect
+ (read-field socket (nth i types)))))
+ (#.+binary-row-message+
+ (error "NYI"))
+ (#.+completed-response-message+
+ (return (values nil (read-socket-value-string socket))))
+ (#.+error-response-message+
+ (let ((message (read-socket-value-string socket)))
+ (error 'postgresql-error
+ :connection connection :message message)))
+ (#.+notice-response-message+
+ (let ((message (read-socket-value-string socket)))
+ (warn 'postgresql-warning
+ :connection connection :message message)))
+ (#.+notification-response-message+
+ (let ((pid (read-socket-value-int32 socket))
+ (message (read-socket-value-string socket)))
+ (when (= pid (postgresql-connection-pid connection))
+ (signal 'postgresql-notification :connection connection
+ :message message))))
+ (t
+ (close-postgresql-connection connection)
+ (error 'postgresql-fatal-error :connection connection
+ :message "Received garbled message from backend")))))))
(defun map-into-indexed (result-seq func seq)
(dotimes (i (length seq))
(declare (fixnum i))
(setf (elt result-seq i)
- (funcall func (elt seq i) i)))
+ (funcall func (elt seq i) i)))
result-seq)
(defun copy-cursor-row (cursor sequence types)
(let* ((connection (postgresql-cursor-connection cursor))
- (socket (postgresql-connection-socket connection))
- (fields (postgresql-cursor-fields cursor)))
+ (socket (postgresql-connection-socket connection))
+ (fields (postgresql-cursor-fields cursor)))
(assert (= (length fields) (length sequence)))
(loop
- (let ((code (read-socket-value-int8 socket)))
- (case code
- (#.+ascii-row-message+
- (return
- #+ignore
- (let* ((count (length sequence))
- (null-vector (read-null-bit-vector socket count)))
- (dotimes (i count)
- (declare (fixnum i))
- (if (zerop (elt null-vector i))
- (setf (elt sequence i) nil)
- (let ((value (read-field socket (nth i types))))
- (setf (elt sequence i) value)))))
- (map-into-indexed
- sequence
- #'(lambda (null-bit i)
- (if (zerop null-bit)
- nil
- (read-field socket (nth i types))))
- (read-null-bit-vector socket (length sequence)))))
- (#.+binary-row-message+
- (error "NYI"))
- (#.+completed-response-message+
- (return (values nil (read-socket-value-string socket))))
- (#.+error-response-message+
- (let ((message (read-socket-value-string socket)))
- (error 'postgresql-error
- :connection connection :message message)))
- (#.+notice-response-message+
- (let ((message (read-socket-value-string socket)))
- (warn 'postgresql-warning
- :connection connection :message message)))
- (#.+notification-response-message+
- (let ((pid (read-socket-value-int32 socket))
- (message (read-socket-value-string socket)))
- (when (= pid (postgresql-connection-pid connection))
- (signal 'postgresql-notification :connection connection
- :message message))))
- (t
- (close-postgresql-connection connection)
- (error 'postgresql-fatal-error :connection connection
- :message "Received garbled message from backend")))))))
+ (let ((code (read-socket-value-int8 socket)))
+ (case code
+ (#.+ascii-row-message+
+ (return
+ #+ignore
+ (let* ((count (length sequence))
+ (null-vector (read-null-bit-vector socket count)))
+ (dotimes (i count)
+ (declare (fixnum i))
+ (if (zerop (elt null-vector i))
+ (setf (elt sequence i) nil)
+ (let ((value (read-field socket (nth i types))))
+ (setf (elt sequence i) value)))))
+ (map-into-indexed
+ sequence
+ #'(lambda (null-bit i)
+ (if (zerop null-bit)
+ nil
+ (read-field socket (nth i types))))
+ (read-null-bit-vector socket (length sequence)))))
+ (#.+binary-row-message+
+ (error "NYI"))
+ (#.+completed-response-message+
+ (return (values nil (read-socket-value-string socket))))
+ (#.+error-response-message+
+ (let ((message (read-socket-value-string socket)))
+ (error 'postgresql-error
+ :connection connection :message message)))
+ (#.+notice-response-message+
+ (let ((message (read-socket-value-string socket)))
+ (warn 'postgresql-warning
+ :connection connection :message message)))
+ (#.+notification-response-message+
+ (let ((pid (read-socket-value-int32 socket))
+ (message (read-socket-value-string socket)))
+ (when (= pid (postgresql-connection-pid connection))
+ (signal 'postgresql-notification :connection connection
+ :message message))))
+ (t
+ (close-postgresql-connection connection)
+ (error 'postgresql-fatal-error :connection connection
+ :message "Received garbled message from backend")))))))
(defun skip-cursor-row (cursor)
(let* ((connection (postgresql-cursor-connection cursor))
- (socket (postgresql-connection-socket connection))
- (fields (postgresql-cursor-fields cursor)))
+ (socket (postgresql-connection-socket connection))
+ (fields (postgresql-cursor-fields cursor)))
(loop
- (let ((code (read-socket-value-int8 socket)))
- (case code
- (#.+ascii-row-message+
- (loop for null-bit across
- (read-null-bit-vector socket (length fields))
- do
- (unless (zerop null-bit)
- (let* ((length (read-socket-value-int32 socket)))
- (loop repeat (- length 4) do (read-byte socket)))))
- (return t))
- (#.+binary-row-message+
- (error "NYI"))
- (#.+completed-response-message+
- (return (values nil (read-socket-value-string socket))))
- (#.+error-response-message+
- (let ((message (read-socket-value-string socket)))
- (error 'postgresql-error
- :connection connection :message message)))
- (#.+notice-response-message+
- (let ((message (read-socket-value-string socket)))
- (warn 'postgresql-warning
- :connection connection :message message)))
- (#.+notification-response-message+
- (let ((pid (read-socket-value-int32 socket))
- (message (read-socket-value-string socket)))
- (when (= pid (postgresql-connection-pid connection))
- (signal 'postgresql-notification :connection connection
- :message message))))
- (t
- (close-postgresql-connection connection)
- (error 'postgresql-fatal-error :connection connection
- :message "Received garbled message from backend")))))))
+ (let ((code (read-socket-value-int8 socket)))
+ (case code
+ (#.+ascii-row-message+
+ (loop for null-bit across
+ (read-null-bit-vector socket (length fields))
+ do
+ (unless (zerop null-bit)
+ (let* ((length (read-socket-value-int32 socket)))
+ (loop repeat (- length 4) do (read-byte socket)))))
+ (return t))
+ (#.+binary-row-message+
+ (error "NYI"))
+ (#.+completed-response-message+
+ (return (values nil (read-socket-value-string socket))))
+ (#.+error-response-message+
+ (let ((message (read-socket-value-string socket)))
+ (error 'postgresql-error
+ :connection connection :message message)))
+ (#.+notice-response-message+
+ (let ((message (read-socket-value-string socket)))
+ (warn 'postgresql-warning
+ :connection connection :message message)))
+ (#.+notification-response-message+
+ (let ((pid (read-socket-value-int32 socket))
+ (message (read-socket-value-string socket)))
+ (when (= pid (postgresql-connection-pid connection))
+ (signal 'postgresql-notification :connection connection
+ :message message))))
+ (t
+ (close-postgresql-connection connection)
+ (error 'postgresql-fatal-error :connection connection
+ :message "Received garbled message from backend")))))))
(defun run-query (connection query &optional (result-types nil))
(start-query-execution connection query)
(wait-for-query-results connection)
(assert (eq status :cursor))
(loop for row = (read-cursor-row cursor result-types)
- while row
- collect row
- finally
- (wait-for-query-results connection))))
+ while row
+ collect row
+ finally
+ (wait-for-query-results connection))))
#+scl
(declaim (ext:maybe-inline read-byte write-byte))
projects / clsql.git / blobdiff