1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: postgresql-socket-api.lisp
6 ;;;; Purpose: Low-level PostgreSQL interface using sockets
7 ;;;; Authors: Kevin M. Rosenberg based on original code by Pierre R. Mai
10 ;;;; This file, part of CLSQL, is Copyright (c) 2002-2010 by Kevin M. Rosenberg
11 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
13 ;;;; CLSQL users are granted the rights to distribute and use this software
14 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
15 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
16 ;;;; *************************************************************************
18 (in-package #:postgresql-socket)
21 ;; FIXME: The file has code specific to sb-unicode and CCL
22 ;; to assume UTF8 encoded strings.
23 ;; Best fix would be to use the user-specified encoding that is now
24 ;; stored in the database object and use the UFFI 2.x encoding functions
25 ;; to convert strings to/from octet vectors. This allows encoding
26 ;; other than UTF8 and also works on all CL implementations that
27 ;; support wide character strings
29 (uffi:def-enum pgsql-ftype
37 (defmethod clsql-sys:database-type-library-loaded ((database-type
38 (eql :postgresql-socket)))
39 "T if foreign library was able to be loaded successfully. Always true for
43 (defmethod clsql-sys:database-type-load-foreign ((database-type (eql :postgresql-socket)))
49 (defmacro define-message-constants (description &rest clauses)
50 (assert (evenp (length clauses)))
51 (loop with seen-characters = nil
52 for (name char) on clauses by #'cddr
53 for char-code = (char-code char)
54 for doc-string = (format nil "~A (~:C): ~A" description char name)
55 if (member char seen-characters)
56 do (error "Duplicate message type ~@C for group ~A" char description)
59 `(defconstant ,name ,char-code ,doc-string)
61 and do (push char seen-characters)
63 (return `(progn ,@result-clauses))))
65 (eval-when (:compile-toplevel :load-toplevel :execute)
66 (define-message-constants "Backend Message Constants"
67 +ascii-row-message+ #\D
68 +authentication-message+ #\R
69 +backend-key-message+ #\K
70 +binary-row-message+ #\B
71 +completed-response-message+ #\C
72 +copy-in-response-message+ #\G
73 +copy-out-response-message+ #\H
74 +cursor-response-message+ #\P
75 +empty-query-response-message+ #\I
76 +error-response-message+ #\E
77 +function-response-message+ #\V
78 +notice-response-message+ #\N
79 +notification-response-message+ #\A
80 +ready-for-query-message+ #\Z
81 +row-description-message+ #\T))
84 (declaim (inline read-byte write-byte))
86 (defun send-socket-value-int32 (socket value)
87 (declare (type stream socket)
88 (type (unsigned-byte 32) value))
89 (write-byte (ldb (byte 8 24) value) socket)
90 (write-byte (ldb (byte 8 16) value) socket)
91 (write-byte (ldb (byte 8 8) value) socket)
92 (write-byte (ldb (byte 8 0) value) socket)
95 (defun send-socket-value-int16 (socket value)
96 (declare (type stream socket)
97 (type (unsigned-byte 16) value))
98 (write-byte (ldb (byte 8 8) value) socket)
99 (write-byte (ldb (byte 8 0) value) socket)
102 (defun send-socket-value-int8 (socket value)
103 (declare (type stream socket)
104 (type (unsigned-byte 8) value))
105 (write-byte (ldb (byte 8 0) value) socket)
108 (defun send-socket-value-char-code (socket value)
109 (declare (type stream socket)
110 (type character value))
111 (write-byte (ldb (byte 8 0) (char-code value)) socket)
114 (defun send-socket-value-string (socket value)
115 (declare (type stream socket)
117 #-(or sb-unicode ccl)
118 (loop for char across value
119 for code = (char-code char)
120 do (write-byte code socket)
121 finally (write-byte 0 socket))
123 (write-sequence (ccl:encode-string-to-octets
124 value :external-format :utf-8) socket)
126 (write-byte 0 socket)
128 (write-sequence (sb-ext:string-to-octets value :null-terminate t)
132 (defun send-socket-value-limstring (socket value limit)
133 (declare (type stream socket)
136 (let ((length (length value)))
137 (dotimes (i (min length limit))
138 (let ((code (char-code (char value i))))
139 (write-byte code socket)))
140 (dotimes (i (- limit length))
141 (write-byte 0 socket)))
145 (defun read-socket-value-int32 (socket)
146 (declare (type stream socket))
147 (declare (optimize (speed 3)))
149 (declare (type (unsigned-byte 32) result))
150 (setf (ldb (byte 8 24) result) (read-byte socket))
151 (setf (ldb (byte 8 16) result) (read-byte socket))
152 (setf (ldb (byte 8 8) result) (read-byte socket))
153 (setf (ldb (byte 8 0) result) (read-byte socket))
156 (defun read-socket-value-int16 (socket)
157 (declare (type stream socket))
159 (declare (type (unsigned-byte 16) result))
160 (setf (ldb (byte 8 8) result) (read-byte socket))
161 (setf (ldb (byte 8 0) result) (read-byte socket))
164 (defun read-socket-value-int8 (socket)
165 (declare (type stream socket))
169 (defun read-socket-value-string (socket)
170 (declare (type stream socket))
171 #-(or sb-unicode ccl)
172 (with-output-to-string (out)
173 (loop for code = (read-byte socket)
175 do (write-char (code-char code) out)))
177 (let ((bytes (make-array 64
178 :element-type '(unsigned-byte 8)
181 (loop for code = (read-byte socket)
183 do (vector-push-extend code bytes))
184 (ccl:decode-string-from-octets bytes :external-format :utf-8))
186 (let ((bytes (make-array 64
187 :element-type '(unsigned-byte 8)
190 (loop for code = (read-byte socket)
192 do (vector-push-extend code bytes))
193 (sb-ext:octets-to-string bytes)))
195 (defmacro define-message-sender (name (&rest args) &rest clauses)
196 (let ((socket-var (gensym))
198 (dolist (clause clauses)
199 (let* ((type (first clause))
200 (fn (intern (concatenate 'string (symbol-name '#:send-socket-value-)
201 (symbol-name type)))))
202 (push `(,fn ,socket-var ,@(rest clause)) body)))
203 `(defun ,name (,socket-var ,@args)
206 (define-message-sender send-startup-message
207 (database user &optional (command-line "") (backend-tty ""))
209 (int32 #x00020000) ; Version 2.0
210 (limstring database 64)
212 (limstring command-line 64)
213 (limstring "" 64) ; Unused
214 (limstring backend-tty 64))
216 (define-message-sender send-terminate-message ()
219 (define-message-sender send-unencrypted-password-message (password)
220 (int32 (+ 5 (length password)))
223 (define-message-sender send-query-message (query)
227 (define-message-sender send-encrypted-password-message (crypted-password)
228 (int32 (+ 5 (length crypted-password)))
229 (string crypted-password))
231 (define-message-sender send-cancel-request (pid key)
233 (int32 80877102) ; Magic
237 (defun read-bytes (socket length)
238 "Read a byte array of the given length from a stream."
239 (declare (type stream socket)
241 (optimize (speed 3) (safety 0)))
242 (let ((result (make-array length :element-type '(unsigned-byte 8))))
243 (read-sequence result socket)
246 (defun read-socket-sequence (stream length &optional (allow-wide t))
247 (declare (stream stream)
248 (optimize (speed 3) (safety 0)))
249 #-(or sb-unicode ccl)
250 (let ((result (make-string length)))
251 (dotimes (i length result)
253 (setf (char result i) (code-char (read-byte stream)))))
255 (let ((bytes (make-array length :element-type '(unsigned-byte 8))))
256 (declare (type (simple-array (unsigned-byte 8) (*)) bytes))
257 (read-sequence bytes stream)
259 (ccl:decode-string-from-octets bytes :external-format :utf-8)
260 (map 'string #'code-char bytes)))
262 (let ((bytes (make-array length :element-type '(unsigned-byte 8))))
263 (declare (type (simple-array (unsigned-byte 8) (*)) bytes))
264 (read-sequence bytes stream)
266 (sb-ext:octets-to-string bytes)
267 (map 'string #'code-char bytes))))
269 ;;; Support for encrypted password transmission
272 (eval-when (:compile-toplevel :load-toplevel :execute)
273 (defvar *crypt-library-loaded* nil)
275 (unless *crypt-library-loaded*
276 (uffi:load-foreign-library
277 (uffi:find-foreign-library "libcrypt"
278 '(#+(or 64bit x86-64) "/usr/lib64/"
279 "/usr/lib/" "/usr/local/lib/" "/lib/"))
280 :supporting-libraries '("c"))
281 (setq *crypt-library-loaded* t)))
283 (in-package :postgresql-socket)
285 (uffi:def-function ("crypt" crypt)
290 (defun crypt-password (password salt)
291 "Encrypt a password for transmission to a PostgreSQL server."
292 (uffi:with-cstring (password-cstring password)
293 (uffi:with-cstring (salt-cstring salt)
294 (uffi:convert-from-cstring
295 (crypt password-cstring salt-cstring)))))
298 ;;;; Condition hierarchy
300 (define-condition postgresql-condition (condition)
301 ((connection :initarg :connection :reader postgresql-condition-connection)
302 (message :initarg :message :reader postgresql-condition-message))
305 (format stream "~@<~A occurred on connection ~A. ~:@_Reason: ~A~:@>"
307 (postgresql-condition-connection c)
308 (postgresql-condition-message c)))))
310 (define-condition postgresql-error (error postgresql-condition)
313 (define-condition postgresql-fatal-error (postgresql-error)
316 (define-condition postgresql-login-error (postgresql-fatal-error)
319 (define-condition postgresql-warning (warning postgresql-condition)
322 (define-condition postgresql-notification (postgresql-condition)
326 (format stream "~@<Asynchronous notification on connection ~A: ~:@_~A~:@>"
327 (postgresql-condition-connection c)
328 (postgresql-condition-message c)))))
332 (defstruct postgresql-connection
344 (defstruct postgresql-cursor
351 (defconstant +postgresql-server-default-port+ 5432
352 "Default port of PostgreSQL server.")
354 (defvar *postgresql-server-socket-timeout* 60
355 "Timeout in seconds for reads from the PostgreSQL server.")
358 (defun open-postgresql-socket (host port)
361 ;; Directory to unix-domain socket
362 (ext:connect-to-unix-socket
364 (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
367 (ext:connect-to-inet-socket host port))))
370 (defun open-postgresql-socket (host port)
373 ;; Directory to unix-domain socket
374 (let ((sock (make-instance 'sb-bsd-sockets:local-socket
376 (sb-bsd-sockets:socket-connect
379 (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
383 (let ((sock (make-instance 'sb-bsd-sockets:inet-socket
386 (sb-bsd-sockets:socket-connect
388 (sb-bsd-sockets:host-ent-address
389 (sb-bsd-sockets:get-host-by-name host))
394 (defun open-postgresql-socket-stream (host port)
395 (system:make-fd-stream
396 (open-postgresql-socket host port)
397 :input t :output t :element-type '(unsigned-byte 8)
399 :timeout *postgresql-server-socket-timeout*))
403 (defun open-postgresql-socket-stream (host port)
404 (sb-bsd-sockets:socket-make-stream
405 (open-postgresql-socket host port) :input t :output t
406 :element-type '(unsigned-byte 8)))
410 (defun open-postgresql-socket-stream (host port)
413 (let ((path (namestring
414 (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
416 (socket:make-socket :type :stream :address-family :file
418 :remote-filename path :local-filename path)))
420 (socket:with-pending-connect
421 (mp:with-timeout (*postgresql-server-socket-timeout* (error "connect failed"))
422 (socket:make-socket :type :stream :address-family :internet
423 :remote-port port :remote-host host
424 :connect :active :nodelay t))))))
427 (defun open-postgresql-socket-stream (host port)
430 (let ((path (namestring
431 (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
433 (ccl:make-socket :type :stream :address-family :file
435 :remote-filename path :local-filename path)))
437 (ccl:make-socket :type :stream :address-family :internet
438 :remote-port port :remote-host host
439 :connect :active :nodelay t))))
442 (defun open-postgresql-socket-stream (host port)
445 (error "File sockets not supported on Lispworks."))
447 (comm:open-tcp-stream host port :direction :io :element-type '(unsigned-byte 8)
448 :read-timeout *postgresql-server-socket-timeout*))
453 (defun open-postgresql-socket-stream (host port)
456 (error "Not supported"))
458 (socket:socket-connect
460 :element-type '(unsigned-byte 8)
461 :timeout *postgresql-server-socket-timeout*))))
464 ;;; Interface Functions
466 (defun open-postgresql-connection (&key (host (cmucl-compat:required-argument))
467 (port +postgresql-server-default-port+)
468 (database (cmucl-compat:required-argument))
469 (user (cmucl-compat:required-argument))
470 options tty password)
471 "Open a connection to a PostgreSQL server with the given parameters.
472 Note that host, database and user arguments must be supplied.
474 If host is a pathname, it is assumed to name a directory containing
475 the local unix-domain sockets of the server, with port selecting which
476 of those sockets to open. If host is a string, it is assumed to be
477 the name of the host running the PostgreSQL server. In that case a
478 TCP connection to the given port on that host is opened in order to
479 communicate with the server. In either case the port argument
480 defaults to `+postgresql-server-default-port+'.
482 Password is the clear-text password to be passed in the authentication
483 phase to the server. Depending on the server set-up, it is either
484 passed in the clear, or encrypted via crypt and a server-supplied
485 salt. In that case the alien function specified by `*crypt-library*'
486 and `*crypt-function-name*' is used for encryption.
488 Note that all the arguments (including the clear-text password
489 argument) are stored in the `postgresql-connection' structure, in
490 order to facilitate automatic reconnection in case of communication
492 (reopen-postgresql-connection
493 (make-postgresql-connection :host host :port port
494 :options (or options "") :tty (or tty "")
495 :database database :user user
496 :password (or password ""))))
498 (defun byte-sequence-to-hex-string (sequence)
499 (string-downcase (format nil "~{~2,'0X~}" (coerce sequence 'list))))
501 (defun encrypt-password-md5 (password user salt)
502 (let ((pass1 (byte-sequence-to-hex-string
503 (md5::md5sum-string (concatenate 'string password user)))))
504 (byte-sequence-to-hex-string
505 (md5:md5sum-sequence (concatenate '(vector (unsigned-byte 8))
506 (map '(vector (unsigned-byte 8)) #'char-code pass1)
509 (defun reopen-postgresql-connection (connection)
510 "Reopen the given PostgreSQL connection. Closes any existing
511 connection, if it is still open."
512 (when (postgresql-connection-open-p connection)
513 (close-postgresql-connection connection))
514 (let ((socket (open-postgresql-socket-stream
515 (postgresql-connection-host connection)
516 (postgresql-connection-port connection))))
519 (setf (postgresql-connection-socket connection) socket)
520 (send-startup-message socket
521 (postgresql-connection-database connection)
522 (postgresql-connection-user connection)
523 (postgresql-connection-options connection)
524 (postgresql-connection-tty connection))
525 (force-output socket)
527 (case (read-socket-value-int8 socket)
528 (#.+authentication-message+
529 (case (read-socket-value-int32 socket)
532 (error 'postgresql-login-error
533 :connection connection
535 "Postmaster expects unsupported Kerberos authentication."))
537 (send-unencrypted-password-message
539 (postgresql-connection-password connection))
540 (force-output socket))
542 (let ((salt (read-socket-sequence socket 2 nil)))
543 (send-encrypted-password-message
546 (postgresql-connection-password connection) salt)))
547 (force-output socket))
549 (let ((salt (read-bytes socket 4)))
550 (let ((pwd (encrypt-password-md5
551 (postgresql-connection-password connection)
552 (postgresql-connection-user connection)
554 (send-encrypted-password-message
556 (concatenate 'string "md5" pwd))))
557 (force-output socket))
559 (error 'postgresql-login-error
560 :connection connection
562 "Postmaster expects unknown authentication method."))))
563 (#.+error-response-message+
564 (let ((message (read-socket-value-string socket)))
565 (error 'postgresql-login-error
566 :connection connection :message message)))
568 (error 'postgresql-login-error
569 :connection connection
571 "Received garbled message from Postmaster"))))
572 ;; Start backend communication
573 (force-output socket)
575 (case (read-socket-value-int8 socket)
576 (#.+backend-key-message+
577 (setf (postgresql-connection-pid connection)
578 (read-socket-value-int32 socket)
579 (postgresql-connection-key connection)
580 (read-socket-value-int32 socket)))
581 (#.+ready-for-query-message+
584 (#.+error-response-message+
585 (let ((message (read-socket-value-string socket)))
586 (error 'postgresql-login-error
587 :connection connection
589 (#.+notice-response-message+
590 (let ((message (read-socket-value-string socket)))
591 (warn 'postgresql-warning :connection connection
594 (error 'postgresql-login-error
595 :connection connection
597 "Received garbled message from Postmaster")))))
601 (defun close-postgresql-connection (connection &optional abort)
604 (send-terminate-message (postgresql-connection-socket connection))))
605 (close (postgresql-connection-socket connection)))
607 (defun postgresql-connection-open-p (connection)
608 (let ((socket (postgresql-connection-socket connection)))
609 (and socket (streamp socket) (open-stream-p socket))))
611 (defun ensure-open-postgresql-connection (connection)
612 (unless (postgresql-connection-open-p connection)
613 (reopen-postgresql-connection connection)))
615 (defun process-async-messages (connection)
616 (assert (postgresql-connection-open-p connection))
617 ;; Process any asnychronous messages
618 (loop with socket = (postgresql-connection-socket connection)
619 while (listen socket)
621 (case (read-socket-value-int8 socket)
622 (#.+ready-for-query-message+)
623 (#.+notice-response-message+
624 (let ((message (read-socket-value-string socket)))
625 (warn 'postgresql-warning :connection connection
627 (#.+notification-response-message+
628 (let ((pid (read-socket-value-int32 socket))
629 (message (read-socket-value-string socket)))
630 (when (= pid (postgresql-connection-pid connection))
631 (signal 'postgresql-notification :connection connection
634 (close-postgresql-connection connection)
635 (error 'postgresql-fatal-error :connection connection
636 :message "Received garbled message from backend")))))
638 (defun start-query-execution (connection query)
639 (ensure-open-postgresql-connection connection)
640 (process-async-messages connection)
641 (send-query-message (postgresql-connection-socket connection) query)
642 (force-output (postgresql-connection-socket connection)))
644 (defun wait-for-query-results (connection)
645 (assert (postgresql-connection-open-p connection))
646 (let ((socket (postgresql-connection-socket connection))
650 (case (read-socket-value-int8 socket)
651 (#.+completed-response-message+
652 (return (values :completed (read-socket-value-string socket))))
653 (#.+cursor-response-message+
654 (setq cursor-name (read-socket-value-string socket)))
655 (#.+row-description-message+
656 (let* ((count (read-socket-value-int16 socket))
661 (read-socket-value-string socket)
662 (read-socket-value-int32 socket)
663 (read-socket-value-int16 socket)
664 (read-socket-value-int32 socket)))))
667 (make-postgresql-cursor :connection connection
670 (#.+copy-in-response-message+
672 (#.+copy-out-response-message+
674 (#.+ready-for-query-message+
678 (#.+error-response-message+
679 (let ((message (read-socket-value-string socket)))
681 (make-condition 'postgresql-error
682 :connection connection :message message))))
683 (#.+notice-response-message+
684 (let ((message (read-socket-value-string socket)))
685 (unless (eq :ignore clsql-sys:*backend-warning-behavior*)
686 (warn 'postgresql-warning
687 :connection connection :message message))))
688 (#.+notification-response-message+
689 (let ((pid (read-socket-value-int32 socket))
690 (message (read-socket-value-string socket)))
691 (when (= pid (postgresql-connection-pid connection))
692 (signal 'postgresql-notification :connection connection
695 (close-postgresql-connection connection)
696 (error 'postgresql-fatal-error :connection connection
697 :message "Received garbled message from backend"))))))
699 (defun read-null-bit-vector (socket count)
700 (let ((result (make-array count :element-type 'bit)))
701 (dotimes (offset (ceiling count 8))
702 (loop with byte = (read-byte socket)
703 for index from (* offset 8) below (min count (* (1+ offset) 8))
704 for weight downfrom 7
705 do (setf (aref result index) (ldb (byte 1 weight) byte))))
709 (defun read-field (socket type)
710 (let ((length (- (read-socket-value-int32 socket) 4)))
713 (read-integer-from-socket socket length))
715 (read-double-from-socket socket length))
717 (read-socket-sequence socket length)))))
719 (uffi:def-constant +char-code-zero+ (char-code #\0))
720 (uffi:def-constant +char-code-minus+ (char-code #\-))
721 (uffi:def-constant +char-code-plus+ (char-code #\+))
722 (uffi:def-constant +char-code-period+ (char-code #\.))
723 (uffi:def-constant +char-code-lower-e+ (char-code #\e))
724 (uffi:def-constant +char-code-upper-e+ (char-code #\E))
726 (defun read-integer-from-socket (socket length)
727 (declare (fixnum length))
731 (first-char (read-byte socket))
733 (declare (fixnum first-char))
734 (decf length) ;; read first char
736 ((= first-char +char-code-minus+)
738 ((= first-char +char-code-plus+)
741 (setq val (- first-char +char-code-zero+))))
747 (- (read-byte socket) +char-code-zero+))))
752 (defmacro ascii-digit (int)
753 (let ((offset (gensym)))
754 `(let ((,offset (- ,int +char-code-zero+)))
755 (declare (fixnum ,int ,offset))
756 (if (and (>= ,offset 0)
761 (defun read-double-from-socket (socket length)
762 (declare (fixnum length))
763 (let ((before-decimal 0)
770 (char (read-byte socket)))
771 (declare (fixnum char exponent decimal-count))
772 (decf length) ;; already read first character
774 ((= char +char-code-minus+)
776 ((= char +char-code-plus+)
778 ((= char +char-code-period+)
781 (setq before-decimal (ascii-digit char))
782 (unless before-decimal
783 (error "Unexpected value"))))
787 (setq char (read-byte socket))
788 ;; (format t "~&len:~D, i:~D, char:~D, minusp:~A, decimalp:~A" length i char minusp decimalp)
789 (let ((weight (ascii-digit char)))
791 ((and weight (not decimalp)) ;; before decimal point
792 (setq before-decimal (+ weight (* 10 before-decimal))))
793 ((and weight decimalp) ;; after decimal point
794 (setq after-decimal (+ weight (* 10 after-decimal)))
795 (incf decimal-count))
796 ((and (= char +char-code-period+))
798 ((or (= char +char-code-lower-e+) ;; E is for exponent
799 (= char +char-code-upper-e+))
800 (setq exponent (read-integer-from-socket socket (- length i 1)))
801 (setq exponent (or exponent 0))
804 (break "Unexpected value"))
807 (setq result (* (+ (coerce before-decimal 'double-float)
809 (expt 10 (- decimal-count))))
817 (defun read-double-from-socket (socket length)
818 (let ((result (make-string length)))
819 (read-socket-sequence result socket)
820 (let ((*read-default-float-format* 'double-float))
821 (read-from-string result))))
823 (defun read-cursor-row (cursor types)
824 (let* ((connection (postgresql-cursor-connection cursor))
825 (socket (postgresql-connection-socket connection))
826 (fields (postgresql-cursor-fields cursor)))
827 (assert (postgresql-connection-open-p connection))
829 (let ((code (read-socket-value-int8 socket)))
831 (#.+ascii-row-message+
833 (loop with count = (length fields)
834 with null-vector = (read-null-bit-vector socket count)
836 for null-bit across null-vector
838 for null-p = (zerop null-bit)
843 (read-field socket (nth i types)))))
844 (#.+binary-row-message+
846 (#.+completed-response-message+
847 (return (values nil (read-socket-value-string socket))))
848 (#.+error-response-message+
849 (let ((message (read-socket-value-string socket)))
850 (error 'postgresql-error
851 :connection connection :message message)))
852 (#.+notice-response-message+
853 (let ((message (read-socket-value-string socket)))
854 (warn 'postgresql-warning
855 :connection connection :message message)))
856 (#.+notification-response-message+
857 (let ((pid (read-socket-value-int32 socket))
858 (message (read-socket-value-string socket)))
859 (when (= pid (postgresql-connection-pid connection))
860 (signal 'postgresql-notification :connection connection
863 (close-postgresql-connection connection)
864 (error 'postgresql-fatal-error :connection connection
865 :message "Received garbled message from backend")))))))
867 (defun map-into-indexed (result-seq func seq)
868 (dotimes (i (length seq))
870 (setf (elt result-seq i)
871 (funcall func (elt seq i) i)))
874 (defun copy-cursor-row (cursor sequence types)
875 (let* ((connection (postgresql-cursor-connection cursor))
876 (socket (postgresql-connection-socket connection))
877 (fields (postgresql-cursor-fields cursor)))
878 (assert (= (length fields) (length sequence)))
880 (let ((code (read-socket-value-int8 socket)))
882 (#.+ascii-row-message+
885 (let* ((count (length sequence))
886 (null-vector (read-null-bit-vector socket count)))
889 (if (zerop (elt null-vector i))
890 (setf (elt sequence i) nil)
891 (let ((value (read-field socket (nth i types))))
892 (setf (elt sequence i) value)))))
895 #'(lambda (null-bit i)
898 (read-field socket (nth i types))))
899 (read-null-bit-vector socket (length sequence)))))
900 (#.+binary-row-message+
902 (#.+completed-response-message+
903 (return (values nil (read-socket-value-string socket))))
904 (#.+error-response-message+
905 (let ((message (read-socket-value-string socket)))
906 (error 'postgresql-error
907 :connection connection :message message)))
908 (#.+notice-response-message+
909 (let ((message (read-socket-value-string socket)))
910 (warn 'postgresql-warning
911 :connection connection :message message)))
912 (#.+notification-response-message+
913 (let ((pid (read-socket-value-int32 socket))
914 (message (read-socket-value-string socket)))
915 (when (= pid (postgresql-connection-pid connection))
916 (signal 'postgresql-notification :connection connection
919 (close-postgresql-connection connection)
920 (error 'postgresql-fatal-error :connection connection
921 :message "Received garbled message from backend")))))))
923 (defun skip-cursor-row (cursor)
924 (let* ((connection (postgresql-cursor-connection cursor))
925 (socket (postgresql-connection-socket connection))
926 (fields (postgresql-cursor-fields cursor)))
928 (let ((code (read-socket-value-int8 socket)))
930 (#.+ascii-row-message+
931 (loop for null-bit across
932 (read-null-bit-vector socket (length fields))
934 (unless (zerop null-bit)
935 (let* ((length (read-socket-value-int32 socket)))
936 (loop repeat (- length 4) do (read-byte socket)))))
938 (#.+binary-row-message+
940 (#.+completed-response-message+
941 (return (values nil (read-socket-value-string socket))))
942 (#.+error-response-message+
943 (let ((message (read-socket-value-string socket)))
944 (error 'postgresql-error
945 :connection connection :message message)))
946 (#.+notice-response-message+
947 (let ((message (read-socket-value-string socket)))
948 (warn 'postgresql-warning
949 :connection connection :message message)))
950 (#.+notification-response-message+
951 (let ((pid (read-socket-value-int32 socket))
952 (message (read-socket-value-string socket)))
953 (when (= pid (postgresql-connection-pid connection))
954 (signal 'postgresql-notification :connection connection
957 (close-postgresql-connection connection)
958 (error 'postgresql-fatal-error :connection connection
959 :message "Received garbled message from backend")))))))
961 (defun run-query (connection query &optional (result-types nil))
962 (start-query-execution connection query)
963 (multiple-value-bind (status cursor)
964 (wait-for-query-results connection)
965 (assert (eq status :cursor))
966 (loop for row = (read-cursor-row cursor result-types)
970 (wait-for-query-results connection))))
973 (declaim (ext:maybe-inline read-byte write-byte))