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
12 ;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg
13 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
15 ;;;; CLSQL users are granted the rights to distribute and use this software
16 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
17 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
18 ;;;; *************************************************************************
20 (in-package #:postgresql-socket
)
22 (uffi:def-enum pgsql-ftype
30 (defmethod clsql-sys:database-type-library-loaded
((database-type
31 (eql :postgresql-socket
)))
32 "T if foreign library was able to be loaded successfully. Always true for
36 (defmethod clsql-sys:database-type-load-foreign
((database-type (eql :postgresql-socket
)))
42 (defmacro define-message-constants
(description &rest clauses
)
43 (assert (evenp (length clauses
)))
44 (loop with seen-characters
= nil
45 for
(name char
) on clauses by
#'cddr
46 for char-code
= (char-code char
)
47 for doc-string
= (format nil
"~A (~:C): ~A" description char name
)
48 if
(member char seen-characters
)
49 do
(error "Duplicate message type ~@C for group ~A" char description
)
52 `(defconstant ,name
,char-code
,doc-string
)
54 and do
(push char seen-characters
)
56 (return `(progn ,@result-clauses
))))
58 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
59 (define-message-constants "Backend Message Constants"
60 +ascii-row-message
+ #\D
61 +authentication-message
+ #\R
62 +backend-key-message
+ #\K
63 +binary-row-message
+ #\B
64 +completed-response-message
+ #\C
65 +copy-in-response-message
+ #\G
66 +copy-out-response-message
+ #\H
67 +cursor-response-message
+ #\P
68 +empty-query-response-message
+ #\I
69 +error-response-message
+ #\E
70 +function-response-message
+ #\V
71 +notice-response-message
+ #\N
72 +notification-response-message
+ #\A
73 +ready-for-query-message
+ #\Z
74 +row-description-message
+ #\T
))
77 (declaim (inline read-byte write-byte
))
79 (defun send-socket-value-int32 (socket value
)
80 (declare (type stream socket
)
81 (type (unsigned-byte 32) value
))
82 (write-byte (ldb (byte 8 24) value
) socket
)
83 (write-byte (ldb (byte 8 16) value
) socket
)
84 (write-byte (ldb (byte 8 8) value
) socket
)
85 (write-byte (ldb (byte 8 0) value
) socket
)
88 (defun send-socket-value-int16 (socket value
)
89 (declare (type stream socket
)
90 (type (unsigned-byte 16) value
))
91 (write-byte (ldb (byte 8 8) value
) socket
)
92 (write-byte (ldb (byte 8 0) value
) socket
)
95 (defun send-socket-value-int8 (socket value
)
96 (declare (type stream socket
)
97 (type (unsigned-byte 8) value
))
98 (write-byte (ldb (byte 8 0) value
) socket
)
101 (defun send-socket-value-char-code (socket value
)
102 (declare (type stream socket
)
103 (type character value
))
104 (write-byte (ldb (byte 8 0) (char-code value
)) socket
)
107 (defun send-socket-value-string (socket value
)
108 (declare (type stream socket
)
111 (loop for char across value
112 for code
= (char-code char
)
113 do
(write-byte code socket
)
114 finally
(write-byte 0 socket
))
116 (write-sequence (sb-ext:string-to-octets value
:null-terminate t
) socket
)
119 (defun send-socket-value-limstring (socket value limit
)
120 (declare (type stream socket
)
123 (let ((length (length value
)))
124 (dotimes (i (min length limit
))
125 (let ((code (char-code (char value i
))))
126 (write-byte code socket
)))
127 (dotimes (i (- limit length
))
128 (write-byte 0 socket
)))
132 (defun read-socket-value-int32 (socket)
133 (declare (type stream socket
))
134 (declare (optimize (speed 3)))
136 (declare (type (unsigned-byte 32) result
))
137 (setf (ldb (byte 8 24) result
) (read-byte socket
))
138 (setf (ldb (byte 8 16) result
) (read-byte socket
))
139 (setf (ldb (byte 8 8) result
) (read-byte socket
))
140 (setf (ldb (byte 8 0) result
) (read-byte socket
))
143 (defun read-socket-value-int16 (socket)
144 (declare (type stream socket
))
146 (declare (type (unsigned-byte 16) result
))
147 (setf (ldb (byte 8 8) result
) (read-byte socket
))
148 (setf (ldb (byte 8 0) result
) (read-byte socket
))
151 (defun read-socket-value-int8 (socket)
152 (declare (type stream socket
))
155 (defun read-socket-value-string (socket)
156 (declare (type stream socket
))
158 (with-output-to-string (out)
159 (loop for code
= (read-byte socket
)
161 do
(write-char (code-char code
) out
)))
163 (let ((bytes (make-array 64
164 :element-type
'(unsigned-byte 8)
167 (loop for code
= (read-byte socket
)
169 do
(vector-push-extend code bytes
))
170 (sb-ext:octets-to-string bytes
)))
173 (defmacro define-message-sender
(name (&rest args
) &rest clauses
)
174 (let ((socket-var (gensym))
176 (dolist (clause clauses
)
177 (let* ((type (first clause
))
178 (fn (intern (concatenate 'string
(symbol-name '#:send-socket-value-
)
179 (symbol-name type
)))))
180 (push `(,fn
,socket-var
,@(rest clause
)) body
)))
181 `(defun ,name
(,socket-var
,@args
)
184 (define-message-sender send-startup-message
185 (database user
&optional
(command-line "") (backend-tty ""))
187 (int32 #x00020000
) ; Version 2.0
188 (limstring database
64)
190 (limstring command-line
64)
191 (limstring "" 64) ; Unused
192 (limstring backend-tty
64))
194 (define-message-sender send-terminate-message
()
197 (define-message-sender send-unencrypted-password-message
(password)
198 (int32 (+ 5 (length password
)))
201 (define-message-sender send-query-message
(query)
205 (define-message-sender send-encrypted-password-message
(crypted-password)
206 (int32 (+ 5 (length crypted-password
)))
207 (string crypted-password
))
209 (define-message-sender send-cancel-request
(pid key
)
211 (int32 80877102) ; Magic
216 (defun read-socket-sequence (stream length
)
217 "KMR -- Added to support reading from binary stream into a string"
218 (declare (stream stream
)
219 (optimize (speed 3) (safety 0)))
221 (let ((result (make-string length
)))
222 (dotimes (i length result
)
224 (setf (char result i
) (code-char (read-byte stream
)))))
226 (let ((bytes (make-array length
:element-type
'(unsigned-byte 8))))
227 (declare (type (simple-array (unsigned-byte 8) (*)) bytes
))
228 (read-sequence bytes stream
)
229 (sb-ext:octets-to-string bytes
)))
232 ;;; Support for encrypted password transmission
235 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
236 (defvar *crypt-library-loaded
* nil
)
238 (unless *crypt-library-loaded
*
239 (uffi:load-foreign-library
240 (uffi:find-foreign-library
"libcrypt"
241 '(#+(or 64bit x86-64
) "/usr/lib64/"
242 "/usr/lib/" "/usr/local/lib/" "/lib/"))
243 :supporting-libraries
'("c"))
244 (setq *crypt-library-loaded
* t
)))
246 (in-package :postgresql-socket
)
248 (uffi:def-function
("crypt" crypt
)
253 (defun crypt-password (password salt
)
254 "Encrypt a password for transmission to a PostgreSQL server."
255 (uffi:with-cstring
(password-cstring password
)
256 (uffi:with-cstring
(salt-cstring salt
)
257 (uffi:convert-from-cstring
258 (crypt password-cstring salt-cstring
)))))
261 ;;;; Condition hierarchy
263 (define-condition postgresql-condition
(condition)
264 ((connection :initarg
:connection
:reader postgresql-condition-connection
)
265 (message :initarg
:message
:reader postgresql-condition-message
))
268 (format stream
"~@<~A occurred on connection ~A. ~:@_Reason: ~A~:@>"
270 (postgresql-condition-connection c
)
271 (postgresql-condition-message c
)))))
273 (define-condition postgresql-error
(error postgresql-condition
)
276 (define-condition postgresql-fatal-error
(postgresql-error)
279 (define-condition postgresql-login-error
(postgresql-fatal-error)
282 (define-condition postgresql-warning
(warning postgresql-condition
)
285 (define-condition postgresql-notification
(postgresql-condition)
289 (format stream
"~@<Asynchronous notification on connection ~A: ~:@_~A~:@>"
290 (postgresql-condition-connection c
)
291 (postgresql-condition-message c
)))))
295 (defstruct postgresql-connection
307 (defstruct postgresql-cursor
314 (defconstant +postgresql-server-default-port
+ 5432
315 "Default port of PostgreSQL server.")
317 (defvar *postgresql-server-socket-timeout
* 60
318 "Timeout in seconds for reads from the PostgreSQL server.")
321 (defun open-postgresql-socket (host port
)
324 ;; Directory to unix-domain socket
325 (ext:connect-to-unix-socket
327 (make-pathname :name
".s.PGSQL" :type
(princ-to-string port
)
330 (ext:connect-to-inet-socket host port
))))
333 (defun open-postgresql-socket (host port
)
336 ;; Directory to unix-domain socket
337 (let ((sock (make-instance 'sb-bsd-sockets
:local-socket
339 (sb-bsd-sockets:socket-connect
342 (make-pathname :name
".s.PGSQL" :type
(princ-to-string port
)
346 (let ((sock (make-instance 'sb-bsd-sockets
:inet-socket
349 (sb-bsd-sockets:socket-connect
351 (sb-bsd-sockets:host-ent-address
352 (sb-bsd-sockets:get-host-by-name host
))
357 (defun open-postgresql-socket-stream (host port
)
358 (system:make-fd-stream
359 (open-postgresql-socket host port
)
360 :input t
:output t
:element-type
'(unsigned-byte 8)
362 :timeout
*postgresql-server-socket-timeout
*))
366 (defun open-postgresql-socket-stream (host port
)
367 (sb-bsd-sockets:socket-make-stream
368 (open-postgresql-socket host port
) :input t
:output t
369 :element-type
'(unsigned-byte 8)))
373 (defun open-postgresql-socket-stream (host port
)
376 (let ((path (namestring
377 (make-pathname :name
".s.PGSQL" :type
(princ-to-string port
)
379 (socket:make-socket
:type
:stream
:address-family
:file
381 :remote-filename path
:local-filename path
)))
383 (socket:with-pending-connect
384 (mp:with-timeout
(*postgresql-server-socket-timeout
* (error "connect failed"))
385 (socket:make-socket
:type
:stream
:address-family
:internet
386 :remote-port port
:remote-host host
387 :connect
:active
:nodelay t
))))))
390 (defun open-postgresql-socket-stream (host port
)
393 (let ((path (namestring
394 (make-pathname :name
".s.PGSQL" :type
(princ-to-string port
)
396 (ccl:make-socket
:type
:stream
:address-family
:file
398 :remote-filename path
:local-filename path
)))
400 (ccl:make-socket
:type
:stream
:address-family
:internet
401 :remote-port port
:remote-host host
402 :connect
:active
:nodelay t
))))
405 (defun open-postgresql-socket-stream (host port
)
408 (error "File sockets not supported on Lispworks."))
410 (comm:open-tcp-stream host port
:direction
:io
:element-type
'(unsigned-byte 8)
411 :read-timeout
*postgresql-server-socket-timeout
*))
416 (defun open-postgresql-socket-stream (host port
)
419 (error "Not supported"))
421 (socket:socket-connect
423 :element-type
'(unsigned-byte 8)
424 :timeout
*postgresql-server-socket-timeout
*))))
427 ;;; Interface Functions
429 (defun open-postgresql-connection (&key
(host (cmucl-compat:required-argument
))
430 (port +postgresql-server-default-port
+)
431 (database (cmucl-compat:required-argument
))
432 (user (cmucl-compat:required-argument
))
433 options tty password
)
434 "Open a connection to a PostgreSQL server with the given parameters.
435 Note that host, database and user arguments must be supplied.
437 If host is a pathname, it is assumed to name a directory containing
438 the local unix-domain sockets of the server, with port selecting which
439 of those sockets to open. If host is a string, it is assumed to be
440 the name of the host running the PostgreSQL server. In that case a
441 TCP connection to the given port on that host is opened in order to
442 communicate with the server. In either case the port argument
443 defaults to `+postgresql-server-default-port+'.
445 Password is the clear-text password to be passed in the authentication
446 phase to the server. Depending on the server set-up, it is either
447 passed in the clear, or encrypted via crypt and a server-supplied
448 salt. In that case the alien function specified by `*crypt-library*'
449 and `*crypt-function-name*' is used for encryption.
451 Note that all the arguments (including the clear-text password
452 argument) are stored in the `postgresql-connection' structure, in
453 order to facilitate automatic reconnection in case of communication
455 (reopen-postgresql-connection
456 (make-postgresql-connection :host host
:port port
457 :options
(or options
"") :tty
(or tty
"")
458 :database database
:user user
459 :password
(or password
""))))
461 (defun encrypt-md5 (plaintext salt
)
463 (format nil
"~{~2,'0X~}"
464 (coerce (md5sum-sequence (concatenate 'string plaintext salt
)) 'list
))))
466 (defun reopen-postgresql-connection (connection)
467 "Reopen the given PostgreSQL connection. Closes any existing
468 connection, if it is still open."
469 (when (postgresql-connection-open-p connection
)
470 (close-postgresql-connection connection
))
471 (let ((socket (open-postgresql-socket-stream
472 (postgresql-connection-host connection
)
473 (postgresql-connection-port connection
))))
476 (setf (postgresql-connection-socket connection
) socket
)
477 (send-startup-message socket
478 (postgresql-connection-database connection
)
479 (postgresql-connection-user connection
)
480 (postgresql-connection-options connection
)
481 (postgresql-connection-tty connection
))
482 (force-output socket
)
484 (case (read-socket-value-int8 socket
)
485 (#.
+authentication-message
+
486 (case (read-socket-value-int32 socket
)
489 (error 'postgresql-login-error
490 :connection connection
492 "Postmaster expects unsupported Kerberos authentication."))
494 (send-unencrypted-password-message
496 (postgresql-connection-password connection
))
497 (force-output socket
))
499 (let ((salt (read-socket-sequence socket
2)))
500 (send-encrypted-password-message
503 (postgresql-connection-password connection
) salt
)))
504 (force-output socket
))
506 (let ((salt (read-socket-sequence socket
4)))
507 (let* ((pwd2 (encrypt-md5 (postgresql-connection-password connection
)
508 (postgresql-connection-user connection
)))
509 (pwd (encrypt-md5 pwd2 salt
)))
510 (send-encrypted-password-message
512 (concatenate 'string
"md5" pwd
))))
513 (force-output socket
))
515 (error 'postgresql-login-error
516 :connection connection
518 "Postmaster expects unknown authentication method."))))
519 (#.
+error-response-message
+
520 (let ((message (read-socket-value-string socket
)))
521 (error 'postgresql-login-error
522 :connection connection
:message message
)))
524 (error 'postgresql-login-error
525 :connection connection
527 "Received garbled message from Postmaster"))))
528 ;; Start backend communication
529 (force-output socket
)
531 (case (read-socket-value-int8 socket
)
532 (#.
+backend-key-message
+
533 (setf (postgresql-connection-pid connection
)
534 (read-socket-value-int32 socket
)
535 (postgresql-connection-key connection
)
536 (read-socket-value-int32 socket
)))
537 (#.
+ready-for-query-message
+
540 (#.
+error-response-message
+
541 (let ((message (read-socket-value-string socket
)))
542 (error 'postgresql-login-error
543 :connection connection
545 (#.
+notice-response-message
+
546 (let ((message (read-socket-value-string socket
)))
547 (warn 'postgresql-warning
:connection connection
550 (error 'postgresql-login-error
551 :connection connection
553 "Received garbled message from Postmaster")))))
557 (defun close-postgresql-connection (connection &optional abort
)
560 (send-terminate-message (postgresql-connection-socket connection
))))
561 (close (postgresql-connection-socket connection
)))
563 (defun postgresql-connection-open-p (connection)
564 (let ((socket (postgresql-connection-socket connection
)))
565 (and socket
(streamp socket
) (open-stream-p socket
))))
567 (defun ensure-open-postgresql-connection (connection)
568 (unless (postgresql-connection-open-p connection
)
569 (reopen-postgresql-connection connection
)))
571 (defun process-async-messages (connection)
572 (assert (postgresql-connection-open-p connection
))
573 ;; Process any asnychronous messages
574 (loop with socket
= (postgresql-connection-socket connection
)
575 while
(listen socket
)
577 (case (read-socket-value-int8 socket
)
578 (#.
+ready-for-query-message
+)
579 (#.
+notice-response-message
+
580 (let ((message (read-socket-value-string socket
)))
581 (warn 'postgresql-warning
:connection connection
583 (#.
+notification-response-message
+
584 (let ((pid (read-socket-value-int32 socket
))
585 (message (read-socket-value-string socket
)))
586 (when (= pid
(postgresql-connection-pid connection
))
587 (signal 'postgresql-notification
:connection connection
590 (close-postgresql-connection connection
)
591 (error 'postgresql-fatal-error
:connection connection
592 :message
"Received garbled message from backend")))))
594 (defun start-query-execution (connection query
)
595 (ensure-open-postgresql-connection connection
)
596 (process-async-messages connection
)
597 (send-query-message (postgresql-connection-socket connection
) query
)
598 (force-output (postgresql-connection-socket connection
)))
600 (defun wait-for-query-results (connection)
601 (assert (postgresql-connection-open-p connection
))
602 (let ((socket (postgresql-connection-socket connection
))
606 (case (read-socket-value-int8 socket
)
607 (#.
+completed-response-message
+
608 (return (values :completed
(read-socket-value-string socket
))))
609 (#.
+cursor-response-message
+
610 (setq cursor-name
(read-socket-value-string socket
)))
611 (#.
+row-description-message
+
612 (let* ((count (read-socket-value-int16 socket
))
617 (read-socket-value-string socket
)
618 (read-socket-value-int32 socket
)
619 (read-socket-value-int16 socket
)
620 (read-socket-value-int32 socket
)))))
623 (make-postgresql-cursor :connection connection
626 (#.
+copy-in-response-message
+
628 (#.
+copy-out-response-message
+
630 (#.
+ready-for-query-message
+
634 (#.
+error-response-message
+
635 (let ((message (read-socket-value-string socket
)))
637 (make-condition 'postgresql-error
638 :connection connection
:message message
))))
639 (#.
+notice-response-message
+
640 (let ((message (read-socket-value-string socket
)))
641 (unless (eq :ignore clsql-sys
:*backend-warning-behavior
*)
642 (warn 'postgresql-warning
643 :connection connection
:message message
))))
644 (#.
+notification-response-message
+
645 (let ((pid (read-socket-value-int32 socket
))
646 (message (read-socket-value-string socket
)))
647 (when (= pid
(postgresql-connection-pid connection
))
648 (signal 'postgresql-notification
:connection connection
651 (close-postgresql-connection connection
)
652 (error 'postgresql-fatal-error
:connection connection
653 :message
"Received garbled message from backend"))))))
655 (defun read-null-bit-vector (socket count
)
656 (let ((result (make-array count
:element-type
'bit
)))
657 (dotimes (offset (ceiling count
8))
658 (loop with byte
= (read-byte socket
)
659 for index from
(* offset
8) below
(min count
(* (1+ offset
) 8))
660 for weight downfrom
7
661 do
(setf (aref result index
) (ldb (byte 1 weight
) byte
))))
665 (defun read-field (socket type
)
666 (let ((length (- (read-socket-value-int32 socket
) 4)))
669 (read-integer-from-socket socket length
))
671 (read-double-from-socket socket length
))
673 (read-socket-sequence socket length
)))))
675 (uffi:def-constant
+char-code-zero
+ (char-code #\
0))
676 (uffi:def-constant
+char-code-minus
+ (char-code #\-
))
677 (uffi:def-constant
+char-code-plus
+ (char-code #\
+))
678 (uffi:def-constant
+char-code-period
+ (char-code #\.
))
679 (uffi:def-constant
+char-code-lower-e
+ (char-code #\e
))
680 (uffi:def-constant
+char-code-upper-e
+ (char-code #\E
))
682 (defun read-integer-from-socket (socket length
)
683 (declare (fixnum length
))
687 (first-char (read-byte socket
))
689 (declare (fixnum first-char
))
690 (decf length
) ;; read first char
692 ((= first-char
+char-code-minus
+)
694 ((= first-char
+char-code-plus
+)
697 (setq val
(- first-char
+char-code-zero
+))))
703 (- (read-byte socket
) +char-code-zero
+))))
708 (defmacro ascii-digit
(int)
709 (let ((offset (gensym)))
710 `(let ((,offset
(- ,int
+char-code-zero
+)))
711 (declare (fixnum ,int
,offset
))
712 (if (and (>= ,offset
0)
717 (defun read-double-from-socket (socket length
)
718 (declare (fixnum length
))
719 (let ((before-decimal 0)
726 (char (read-byte socket
)))
727 (declare (fixnum char exponent decimal-count
))
728 (decf length
) ;; already read first character
730 ((= char
+char-code-minus
+)
732 ((= char
+char-code-plus
+)
734 ((= char
+char-code-period
+)
737 (setq before-decimal
(ascii-digit char
))
738 (unless before-decimal
739 (error "Unexpected value"))))
743 (setq char
(read-byte socket
))
744 ;; (format t "~&len:~D, i:~D, char:~D, minusp:~A, decimalp:~A" length i char minusp decimalp)
745 (let ((weight (ascii-digit char
)))
747 ((and weight
(not decimalp
)) ;; before decimal point
748 (setq before-decimal
(+ weight
(* 10 before-decimal
))))
749 ((and weight decimalp
) ;; after decimal point
750 (setq after-decimal
(+ weight
(* 10 after-decimal
)))
751 (incf decimal-count
))
752 ((and (= char
+char-code-period
+))
754 ((or (= char
+char-code-lower-e
+) ;; E is for exponent
755 (= char
+char-code-upper-e
+))
756 (setq exponent
(read-integer-from-socket socket
(- length i
1)))
757 (setq exponent
(or exponent
0))
760 (break "Unexpected value"))
763 (setq result
(* (+ (coerce before-decimal
'double-float
)
765 (expt 10 (- decimal-count
))))
773 (defun read-double-from-socket (socket length
)
774 (let ((result (make-string length
)))
775 (read-socket-sequence result socket
)
776 (let ((*read-default-float-format
* 'double-float
))
777 (read-from-string result
))))
779 (defun read-cursor-row (cursor types
)
780 (let* ((connection (postgresql-cursor-connection cursor
))
781 (socket (postgresql-connection-socket connection
))
782 (fields (postgresql-cursor-fields cursor
)))
783 (assert (postgresql-connection-open-p connection
))
785 (let ((code (read-socket-value-int8 socket
)))
787 (#.
+ascii-row-message
+
789 (loop with count
= (length fields
)
790 with null-vector
= (read-null-bit-vector socket count
)
792 for null-bit across null-vector
794 for null-p
= (zerop null-bit
)
799 (read-field socket
(nth i types
)))))
800 (#.
+binary-row-message
+
802 (#.
+completed-response-message
+
803 (return (values nil
(read-socket-value-string socket
))))
804 (#.
+error-response-message
+
805 (let ((message (read-socket-value-string socket
)))
806 (error 'postgresql-error
807 :connection connection
:message message
)))
808 (#.
+notice-response-message
+
809 (let ((message (read-socket-value-string socket
)))
810 (warn 'postgresql-warning
811 :connection connection
:message message
)))
812 (#.
+notification-response-message
+
813 (let ((pid (read-socket-value-int32 socket
))
814 (message (read-socket-value-string socket
)))
815 (when (= pid
(postgresql-connection-pid connection
))
816 (signal 'postgresql-notification
:connection connection
819 (close-postgresql-connection connection
)
820 (error 'postgresql-fatal-error
:connection connection
821 :message
"Received garbled message from backend")))))))
823 (defun map-into-indexed (result-seq func seq
)
824 (dotimes (i (length seq
))
826 (setf (elt result-seq i
)
827 (funcall func
(elt seq i
) i
)))
830 (defun copy-cursor-row (cursor sequence types
)
831 (let* ((connection (postgresql-cursor-connection cursor
))
832 (socket (postgresql-connection-socket connection
))
833 (fields (postgresql-cursor-fields cursor
)))
834 (assert (= (length fields
) (length sequence
)))
836 (let ((code (read-socket-value-int8 socket
)))
838 (#.
+ascii-row-message
+
841 (let* ((count (length sequence
))
842 (null-vector (read-null-bit-vector socket count
)))
845 (if (zerop (elt null-vector i
))
846 (setf (elt sequence i
) nil
)
847 (let ((value (read-field socket
(nth i types
))))
848 (setf (elt sequence i
) value
)))))
851 #'(lambda (null-bit i
)
854 (read-field socket
(nth i types
))))
855 (read-null-bit-vector socket
(length sequence
)))))
856 (#.
+binary-row-message
+
858 (#.
+completed-response-message
+
859 (return (values nil
(read-socket-value-string socket
))))
860 (#.
+error-response-message
+
861 (let ((message (read-socket-value-string socket
)))
862 (error 'postgresql-error
863 :connection connection
:message message
)))
864 (#.
+notice-response-message
+
865 (let ((message (read-socket-value-string socket
)))
866 (warn 'postgresql-warning
867 :connection connection
:message message
)))
868 (#.
+notification-response-message
+
869 (let ((pid (read-socket-value-int32 socket
))
870 (message (read-socket-value-string socket
)))
871 (when (= pid
(postgresql-connection-pid connection
))
872 (signal 'postgresql-notification
:connection connection
875 (close-postgresql-connection connection
)
876 (error 'postgresql-fatal-error
:connection connection
877 :message
"Received garbled message from backend")))))))
879 (defun skip-cursor-row (cursor)
880 (let* ((connection (postgresql-cursor-connection cursor
))
881 (socket (postgresql-connection-socket connection
))
882 (fields (postgresql-cursor-fields cursor
)))
884 (let ((code (read-socket-value-int8 socket
)))
886 (#.
+ascii-row-message
+
887 (loop for null-bit across
888 (read-null-bit-vector socket
(length fields
))
890 (unless (zerop null-bit
)
891 (let* ((length (read-socket-value-int32 socket
)))
892 (loop repeat
(- length
4) do
(read-byte socket
)))))
894 (#.
+binary-row-message
+
896 (#.
+completed-response-message
+
897 (return (values nil
(read-socket-value-string socket
))))
898 (#.
+error-response-message
+
899 (let ((message (read-socket-value-string socket
)))
900 (error 'postgresql-error
901 :connection connection
:message message
)))
902 (#.
+notice-response-message
+
903 (let ((message (read-socket-value-string socket
)))
904 (warn 'postgresql-warning
905 :connection connection
:message message
)))
906 (#.
+notification-response-message
+
907 (let ((pid (read-socket-value-int32 socket
))
908 (message (read-socket-value-string socket
)))
909 (when (= pid
(postgresql-connection-pid connection
))
910 (signal 'postgresql-notification
:connection connection
913 (close-postgresql-connection connection
)
914 (error 'postgresql-fatal-error
:connection connection
915 :message
"Received garbled message from backend")))))))
917 (defun run-query (connection query
&optional
(result-types nil
))
918 (start-query-execution connection query
)
919 (multiple-value-bind (status cursor
)
920 (wait-for-query-results connection
)
921 (assert (eq status
:cursor
))
922 (loop for row
= (read-cursor-row cursor result-types
)
926 (wait-for-query-results connection
))))
929 (declaim (ext:maybe-inline read-byte write-byte
))