interfaces/postgresql-socket/postgresql-socket-api.cl

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          postgresql-socket.cl
   6 ;;;; Purpose:       Low-level PostgreSQL interface using sockets
   7 ;;;; Programmers:   Kevin M. Rosenberg based on
   8 ;;;;                Original code by Pierre R. Mai
   9 ;;;;
  10 ;;;; Date Started:  Feb 2002
  11 ;;;;
  12 ;;;; $Id: postgresql-socket-api.cl,v 1.4 2002/03/25 23:30:49 kevin Exp $
  13 ;;;;
  14 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
  15 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
  16 ;;;;
  17 ;;;; CLSQL users are granted the rights to distribute and use this software
  18 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  19 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  20 ;;;; *************************************************************************
  21
  22
  23 ;;;; Changes by Kevin Rosenberg
  24 ;;;;  - Added socket open functions for Allegro and Lispworks
  25 ;;;;  - Changed CMUCL FFI to UFFI
  26 ;;;;  - Added necessary (force-output) for socket streams on
  27 ;;;;     Allegro and Lispworks
  28 ;;;;  - Added initialization variable
  29 ;;;;  - Added field type processing
  30
  31
  32 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
  33 (in-package :postgresql-socket)
  34
  35 (uffi:def-enum pgsql-ftype
  36     ((:bytea 17)
  37      (:int2 21)
  38      (:int4 23)
  39      (:float4 700)
  40      (:float8 701)))
  41
  42 (defmethod database-type-library-loaded ((database-type
  43                                           (eql :postgresql-socket)))
  44   "T if foreign library was able to be loaded successfully. Always true for
  45 socket interface"
  46   t)
  47
  48
  49 ;;; Message I/O stuff
  50
  51 (defmacro define-message-constants (description &rest clauses)
  52   (assert (evenp (length clauses)))
  53   (loop with seen-characters = nil
  54         for (name char) on clauses by #'cddr
  55         for char-code = (char-code char)
  56         for doc-string = (format nil "~A (~:C): ~A" description char name)
  57         if (member char seen-characters)
  58         do (error "Duplicate message type ~@C for group ~A" char description)
  59         else
  60         collect
  61         `(defconstant ,name ,char-code ,doc-string)
  62         into result-clauses
  63         and do (push char seen-characters)
  64       finally
  65         (return `(progn ,@result-clauses))))
  66
  67 (eval-when (:compile-toplevel :load-toplevel :execute)
  68 (define-message-constants "Backend Message Constants"
  69   +ascii-row-message+ #\D
  70   +authentication-message+ #\R
  71   +backend-key-message+ #\K
  72   +binary-row-message+ #\B
  73   +completed-response-message+ #\C
  74   +copy-in-response-message+ #\G
  75   +copy-out-response-message+ #\H
  76   +cursor-response-message+ #\P
  77   +empty-query-response-message+ #\I
  78   +error-response-message+ #\E
  79   +function-response-message+ #\V
  80   +notice-response-message+ #\N
  81   +notification-response-message+ #\A
  82   +ready-for-query-message+ #\Z
  83   +row-description-message+ #\T))
  84
  85 (defgeneric send-socket-value (type socket value))
  86
  87 (defmethod send-socket-value ((type (eql 'int32)) socket (value integer))
  88   (write-byte (ldb (byte 8 24) value) socket)
  89   (write-byte (ldb (byte 8 16) value) socket)
  90   (write-byte (ldb (byte 8 8) value) socket)
  91   (write-byte (ldb (byte 8 0) value) socket))
  92
  93 (defmethod send-socket-value ((type (eql 'int16)) socket (value integer))
  94   (write-byte (ldb (byte 8 8) value) socket)
  95   (write-byte (ldb (byte 8 0) value) socket))
  96
  97 (defmethod send-socket-value ((type (eql 'int8)) socket (value integer))
  98   (write-byte (ldb (byte 8 0) value) socket))
  99
 100 (defmethod send-socket-value ((type (eql 'string)) socket (value string))
 101   (loop for char across value
 102         for code = (char-code char)
 103         do (write-byte code socket)
 104         finally (write-byte 0 socket)))
 105
 106 (defmethod send-socket-value ((type (eql 'limstring)) socket (value string))
 107   (loop for char across value
 108         for code = (char-code char)
 109         do (write-byte code socket)))
 110
 111 (defmethod send-socket-value ((type (eql 'byte)) socket (value integer))
 112   (write-byte value socket))
 113
 114 (defmethod send-socket-value ((type (eql 'byte)) socket (value character))
 115   (write-byte (char-code value) socket))
 116
 117 (defmethod send-socket-value ((type (eql 'byte)) socket value)
 118   (write-sequence value socket))
 119
 120 (defgeneric read-socket-value (type socket))
 121
 122 (defmethod read-socket-value ((type (eql 'int32)) socket)
 123   (let ((result 0))
 124     (setf (ldb (byte 8 24) result) (read-byte socket))
 125     (setf (ldb (byte 8 16) result) (read-byte socket))
 126     (setf (ldb (byte 8 8) result) (read-byte socket))
 127     (setf (ldb (byte 8 0) result) (read-byte socket))
 128     result))
 129
 130 (defmethod read-socket-value ((type (eql 'int16)) socket)
 131   (let ((result 0))
 132     (setf (ldb (byte 8 8) result) (read-byte socket))
 133     (setf (ldb (byte 8 0) result) (read-byte socket))
 134     result))
 135
 136 (defmethod read-socket-value ((type (eql 'int8)) socket)
 137   (read-byte socket))
 138
 139 (defmethod read-socket-value ((type (eql 'string)) socket)
 140   (with-output-to-string (out)
 141     (loop for code = (read-byte socket)
 142           until (zerop code)
 143           do (write-char (code-char code) out))))
 144
 145 (defgeneric skip-socket-value (type socket))
 146
 147 (defmethod skip-socket-value ((type (eql 'int32)) socket)
 148   (dotimes (i 4) (read-byte socket)))
 149
 150 (defmethod skip-socket-value ((type (eql 'int16)) socket)
 151   (dotimes (i 2) (read-byte socket)))
 152
 153 (defmethod skip-socket-value ((type (eql 'int8)) socket)
 154   (read-byte socket))
 155
 156 (defmethod skip-socket-value ((type (eql 'string)) socket)
 157   (loop until (zerop (read-byte socket))))
 158
 159 (defmacro define-message-sender (name (&rest args) &rest clauses)
 160   (loop with socket-var = (gensym)
 161         for (type value) in clauses
 162         collect
 163         `(send-socket-value ',type ,socket-var ,value)
 164         into body
 165       finally
 166         (return
 167           `(defun ,name (,socket-var ,@args)
 168              ,@body))))
 169
 170 (defun pad-limstring (string limit)
 171   (let ((result (make-string limit :initial-element #\NULL)))
 172     (loop for char across string
 173           for index from 0 below limit
 174           do (setf (char result index) char))
 175     result))
 176
 177 (define-message-sender send-startup-message
 178     (database user &optional (command-line "") (backend-tty ""))
 179   (int32 296)                           ; Length
 180   (int32 #x00020000)                    ; Version 2.0
 181   (limstring (pad-limstring database 64))
 182   (limstring (pad-limstring user 32))
 183   (limstring (pad-limstring command-line 64))
 184   (limstring (pad-limstring "" 64))     ; Unused
 185   (limstring (pad-limstring backend-tty 64)))
 186
 187 (define-message-sender send-terminate-message ()
 188   (byte #\X))
 189
 190 (define-message-sender send-unencrypted-password-message (password)
 191   (int32 (+ 5 (length password)))
 192   (string password))
 193
 194 (define-message-sender send-query-message (query)
 195   (byte #\Q)
 196   (string query))
 197
 198 (define-message-sender send-encrypted-password-message (crypted-password)
 199   (int32 (+ 5 (length crypted-password)))
 200   (string crypted-password))
 201
 202 (define-message-sender send-cancel-request (pid key)
 203   (int32 16)                            ; Length
 204   (int32 80877102)                      ; Magic
 205   (int32 pid)
 206   (int32 key))
 207
 208
 209 (defun read-socket-sequence (string stream)
 210 "KMR -- Added to support reading from binary stream into a string"
 211   (declare (optimize (speed 3) (safety 0)))
 212   (dotimes (i (length string))
 213     (declare (fixnum i))
 214     (setf (char string i) (code-char (read-byte stream))))
 215   string)
 216
 217
 218 ;;; Support for encrypted password transmission
 219
 220 (defconstant +crypt-library+ "/usr/lib/libcrypt.so"
 221   "Name of the shared library to load in order to access the crypt
 222 function named by `*crypt-function-name*'.")
 223
 224 (defvar *crypt-library-loaded* nil)
 225
 226 (defun crypt-password (password salt)
 227   "Encrypt a password for transmission to a PostgreSQL server."
 228   (unless *crypt-library-loaded*
 229     (uffi:load-foreign-library +crypt-library+ :supporting-libaries '("c"))
 230     (eval (uffi:def-function "crypt"
 231               ((key :cstring)
 232                (salt :cstring))
 233             :returning :cstring))
 234     (setq *crypt-library-loaded* t))
 235    (uffi:with-cstring (password-cstring password)
 236      (uffi:with-cstring (salt-cstring salt)
 237        (uffi:convert-from-cstring (crypt password-cstring salt-cstring)))))
 238 ;;; Condition hierarchy
 239
 240 (define-condition postgresql-condition (condition)
 241   ((connection :initarg :connection :reader postgresql-condition-connection)
 242    (message :initarg :message :reader postgresql-condition-message))
 243   (:report
 244    (lambda (c stream)
 245      (format stream "~@<~A occurred on connection ~A. ~:@_Reason: ~A~:@>"
 246              (type-of c)
 247              (postgresql-condition-connection c)
 248              (postgresql-condition-message c)))))
 249
 250 (define-condition postgresql-error (error postgresql-condition)
 251   ())
 252
 253 (define-condition postgresql-fatal-error (postgresql-error)
 254   ())
 255
 256 (define-condition postgresql-login-error (postgresql-fatal-error)
 257   ())
 258
 259 (define-condition postgresql-warning (warning postgresql-condition)
 260   ())
 261
 262 (define-condition postgresql-notification (postgresql-condition)
 263   ()
 264   (:report
 265    (lambda (c stream)
 266      (format stream "~@<Asynchronous notification on connection ~A: ~:@_~A~:@>"
 267              (postgresql-condition-connection c)
 268              (postgresql-condition-message c)))))
 269
 270 ;;; Structures
 271
 272 (defstruct postgresql-connection
 273   host
 274   port
 275   database
 276   user
 277   password
 278   options
 279   tty
 280   socket
 281   pid
 282   key)
 283
 284 (defstruct postgresql-cursor
 285   connection
 286   name
 287   fields)
 288
 289 ;;; Socket stuff
 290
 291 (defconstant +postgresql-server-default-port+ 5432
 292   "Default port of PostgreSQL server.")
 293
 294 (defvar *postgresql-server-socket-timeout* 60
 295   "Timeout in seconds for reads from the PostgreSQL server.")
 296
 297
 298 #+cmu
 299 (defun open-postgresql-socket (host port)
 300   (etypecase host
 301     (pathname
 302      ;; Directory to unix-domain socket
 303      (ext:connect-to-unix-socket
 304       (namestring
 305        (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
 306                       :defaults host))))
 307     (string
 308      (ext:connect-to-inet-socket host port))))
 309
 310 #+cmu
 311 (defun open-postgresql-socket-stream (host port)
 312   (system:make-fd-stream
 313    (open-postgresql-socket host port)
 314    :input t :output t :element-type '(unsigned-byte 8)
 315    :buffering :none
 316    :timeout *postgresql-server-socket-timeout*))
 317
 318 #+allegro
 319 (defun open-postgresql-socket-stream (host port)
 320   (etypecase host
 321     (pathname
 322      (let ((path (namestring
 323                   (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
 324                                  :defaults host))))
 325        (socket:make-socket :type :stream :address-family :file
 326                            :connect :active
 327                            :remote-filename path :local-filename path)))
 328     (string
 329      (socket:with-pending-connect
 330          (mp:with-timeout (*postgresql-server-socket-timeout* (error "connect failed"))
 331            (socket:make-socket :type :stream :address-family :internet
 332                                :remote-port port :remote-host host
 333                                :connect :active :nodelay t))))
 334     ))
 335
 336 #+lispworks
 337 (defun open-postgresql-socket-stream (host port)
 338   (etypecase host
 339     (pathname
 340      (error "File sockets not supported on Lispworks."))
 341     (string
 342      (comm:open-tcp-stream host port :direction :io :element-type '(unsigned-byte 8)
 343                            :read-timeout *postgresql-server-socket-timeout*))
 344     ))
 345
 346 ;;; Interface Functions
 347
 348 (defun open-postgresql-connection (&key (host (cmucl-compat:required-argument))
 349                                         (port +postgresql-server-default-port+)
 350                                         (database (cmucl-compat:required-argument))
 351                                         (user (cmucl-compat:required-argument))
 352                                         options tty password)
 353   "Open a connection to a PostgreSQL server with the given parameters.
 354 Note that host, database and user arguments must be supplied.
 355
 356 If host is a pathname, it is assumed to name a directory containing
 357 the local unix-domain sockets of the server, with port selecting which
 358 of those sockets to open.  If host is a string, it is assumed to be
 359 the name of the host running the PostgreSQL server.  In that case a
 360 TCP connection to the given port on that host is opened in order to
 361 communicate with the server.  In either case the port argument
 362 defaults to `+postgresql-server-default-port+'.
 363
 364 Password is the clear-text password to be passed in the authentication
 365 phase to the server.  Depending on the server set-up, it is either
 366 passed in the clear, or encrypted via crypt and a server-supplied
 367 salt.  In that case the alien function specified by `*crypt-library*'
 368 and `*crypt-function-name*' is used for encryption.
 369
 370 Note that all the arguments (including the clear-text password
 371 argument) are stored in the `postgresql-connection' structure, in
 372 order to facilitate automatic reconnection in case of communication
 373 troubles."
 374   (reopen-postgresql-connection
 375    (make-postgresql-connection :host host :port port
 376                                :options (or options "") :tty (or tty "")
 377                                :database database :user user
 378                                :password (or password ""))))
 379
 380 (defun reopen-postgresql-connection (connection)
 381   "Reopen the given PostgreSQL connection.  Closes any existing
 382 connection, if it is still open."
 383   (when (postgresql-connection-open-p connection)
 384     (close-postgresql-connection connection))
 385   (let ((socket (open-postgresql-socket-stream
 386                   (postgresql-connection-host connection)
 387                   (postgresql-connection-port connection))))
 388     (unwind-protect
 389          (progn
 390            (setf (postgresql-connection-socket connection) socket)
 391            (send-startup-message socket
 392                                  (postgresql-connection-database connection)
 393                                  (postgresql-connection-user connection)
 394                                  (postgresql-connection-options connection)
 395                                  (postgresql-connection-tty connection))
 396            (force-output socket)
 397            (loop
 398                (case (read-socket-value 'int8 socket)
 399                  (#.+authentication-message+
 400                   (case (read-socket-value 'int32 socket)
 401                     (0 (return))
 402                     ((1 2)
 403                      (error 'postgresql-login-error
 404                             :connection connection
 405                             :message
 406                             "Postmaster expects unsupported Kerberos authentication."))
 407                     (3
 408                      (send-unencrypted-password-message
 409                       socket
 410                       (postgresql-connection-password connection)))
 411                     (4
 412                      (let ((salt (make-string 2)))
 413                        (read-socket-sequence salt socket)
 414                        (send-encrypted-password-message
 415                         socket
 416                         (crypt-password
 417                          (postgresql-connection-password connection) salt))))
 418                     (t
 419                      (error 'postgresql-login-error
 420                             :connection connection
 421                             :message
 422                             "Postmaster expects unknown authentication method."))))
 423                  (#.+error-response-message+
 424                   (let ((message (read-socket-value 'string socket)))
 425                     (error 'postgresql-login-error
 426                            :connection connection :message message)))
 427                  (t
 428                   (error 'postgresql-login-error
 429                          :connection connection
 430                          :message
 431                          "Received garbled message from Postmaster"))))
 432            ;; Start backend communication
 433            (force-output socket)
 434            (loop
 435                (case (read-socket-value 'int8 socket)
 436                  (#.+backend-key-message+
 437                   (setf (postgresql-connection-pid connection)
 438                         (read-socket-value 'int32 socket)
 439                         (postgresql-connection-key connection)
 440                         (read-socket-value 'int32 socket)))
 441                  (#.+ready-for-query-message+
 442                   (setq socket nil)
 443                   (return connection))
 444                  (#.+error-response-message+
 445                   (let ((message (read-socket-value 'string socket)))
 446                     (error 'postgresql-login-error
 447                            :connection connection
 448                            :message message)))
 449                  (#.+notice-response-message+
 450                   (let ((message (read-socket-value 'string socket)))
 451                     (warn 'postgresql-warning :connection connection
 452                           :message message)))
 453                  (t
 454                   (error 'postgresql-login-error
 455                          :connection connection
 456                          :message
 457                          "Received garbled message from Postmaster")))))
 458       (when socket
 459         (close socket)))))
 460
 461 (defun close-postgresql-connection (connection &optional abort)
 462   (unless abort
 463     (ignore-errors
 464       (send-terminate-message (postgresql-connection-socket connection))))
 465   (close (postgresql-connection-socket connection)))
 466
 467 (defun postgresql-connection-open-p (connection)
 468   (let ((socket (postgresql-connection-socket connection)))
 469     (and socket (streamp socket) (open-stream-p socket))))
 470
 471 (defun ensure-open-postgresql-connection (connection)
 472   (unless (postgresql-connection-open-p connection)
 473     (reopen-postgresql-connection connection)))
 474
 475 (defun process-async-messages (connection)
 476   (assert (postgresql-connection-open-p connection))
 477   ;; Process any asnychronous messages
 478   (loop with socket = (postgresql-connection-socket connection)
 479         while (listen socket)
 480         do
 481         (case (read-socket-value 'int8 socket)
 482           (#.+notice-response-message+
 483            (let ((message (read-socket-value 'string socket)))
 484              (warn 'postgresql-warning :connection connection
 485                    :message message)))
 486           (#.+notification-response-message+
 487            (let ((pid (read-socket-value 'int32 socket))
 488                  (message (read-socket-value 'string socket)))
 489              (when (= pid (postgresql-connection-pid connection))
 490                (signal 'postgresql-notification :connection connection
 491                        :message message))))
 492           (t
 493            (close-postgresql-connection connection)
 494            (error 'postgresql-fatal-error :connection connection
 495                   :message "Received garbled message from backend")))))
 496
 497 (defun start-query-execution (connection query)
 498   (ensure-open-postgresql-connection connection)
 499   (process-async-messages connection)
 500   (send-query-message (postgresql-connection-socket connection) query)
 501   (force-output (postgresql-connection-socket connection)))
 502
 503 (defun wait-for-query-results (connection)
 504   (assert (postgresql-connection-open-p connection))
 505   (let ((socket (postgresql-connection-socket connection))
 506         (cursor-name nil)
 507         (error nil))
 508     (loop
 509         (case (read-socket-value 'int8 socket)
 510           (#.+completed-response-message+
 511            (return (values :completed (read-socket-value 'string socket))))
 512           (#.+cursor-response-message+
 513            (setq cursor-name (read-socket-value 'string socket)))
 514           (#.+row-description-message+
 515            (let* ((count (read-socket-value 'int16 socket))
 516                   (fields
 517                    (loop repeat count
 518                      collect
 519                      (list
 520                       (read-socket-value 'string socket)
 521                       (read-socket-value 'int32 socket)
 522                       (read-socket-value 'int16 socket)
 523                       (read-socket-value 'int32 socket)))))
 524              (return
 525                (values :cursor
 526                        (make-postgresql-cursor :connection connection
 527                                                :name cursor-name
 528                                                :fields fields)))))
 529           (#.+copy-in-response-message+
 530            (return :copy-in))
 531           (#.+copy-out-response-message+
 532            (return :copy-out))
 533           (#.+ready-for-query-message+
 534            (when error
 535              (error error))
 536            (return nil))
 537           (#.+error-response-message+
 538            (let ((message (read-socket-value 'string socket)))
 539              (setq error
 540                    (make-condition 'postgresql-error
 541                                    :connection connection :message message))))
 542           (#.+notice-response-message+
 543            (let ((message (read-socket-value 'string socket)))
 544              (warn 'postgresql-warning
 545                    :connection connection :message message)))
 546           (#.+notification-response-message+
 547            (let ((pid (read-socket-value 'int32 socket))
 548                  (message (read-socket-value 'string socket)))
 549              (when (= pid (postgresql-connection-pid connection))
 550                (signal 'postgresql-notification :connection connection
 551                        :message message))))
 552           (t
 553            (close-postgresql-connection connection)
 554            (error 'postgresql-fatal-error :connection connection
 555                   :message "Received garbled message from backend"))))))
 556
 557 (defun read-null-bit-vector (socket count)
 558   (let ((result (make-array count :element-type 'bit)))
 559     (dotimes (offset (ceiling count 8))
 560       (loop with byte = (read-byte socket)
 561             for index from (* offset 8) below (min count (* (1+ offset) 8))
 562             for weight downfrom 7
 563             do (setf (aref result index) (ldb (byte 1 weight) byte))))
 564     result))
 565
 566 (defun read-field (socket type)
 567   (let* ((length (read-socket-value 'int32 socket))
 568          (result (make-string (- length 4))))
 569     (read-socket-sequence result socket)
 570     (case type
 571       (:int
 572        (parse-integer result))
 573       (:double
 574        (let ((*read-default-float-format* 'double-float))
 575          (read-from-string result)))
 576       (t
 577        result))))
 578
 579 (defun read-cursor-row (cursor field-types)
 580   (let* ((connection (postgresql-cursor-connection cursor))
 581          (socket (postgresql-connection-socket connection))
 582          (fields (postgresql-cursor-fields cursor)))
 583     (assert (postgresql-connection-open-p connection))
 584     (loop
 585         (let ((code (read-socket-value 'int8 socket)))
 586           (case code
 587             (#.+ascii-row-message+
 588              (return
 589                (loop with count = (length fields)
 590                      with null-vector = (read-null-bit-vector socket count)
 591                      repeat count
 592                      for null-bit across null-vector
 593                      for i from 0
 594                      for null-p = (zerop null-bit)
 595                      if null-p
 596                      collect nil
 597                      else
 598                      collect
 599                      (read-field socket (nth i field-types)))))
 600             (#.+binary-row-message+
 601              (error "NYI"))
 602             (#.+completed-response-message+
 603              (return (values nil (read-socket-value 'string socket))))
 604             (#.+error-response-message+
 605              (let ((message (read-socket-value 'string socket)))
 606                (error 'postgresql-error
 607                       :connection connection :message message)))
 608             (#.+notice-response-message+
 609              (let ((message (read-socket-value 'string socket)))
 610                (warn 'postgresql-warning
 611                      :connection connection :message message)))
 612             (#.+notification-response-message+
 613              (let ((pid (read-socket-value 'int32 socket))
 614                    (message (read-socket-value 'string socket)))
 615                (when (= pid (postgresql-connection-pid connection))
 616                  (signal 'postgresql-notification :connection connection
 617                          :message message))))
 618             (t
 619              (close-postgresql-connection connection)
 620              (error 'postgresql-fatal-error :connection connection
 621                     :message "Received garbled message from backend")))))))
 622
 623 (defun map-into-indexed (result-seq func seq)
 624   (dotimes (i (length seq))
 625     (declare (fixnum i))
 626     (setf (elt result-seq i)
 627           (funcall func (elt seq i) i)))
 628   result-seq)
 629
 630 (defun copy-cursor-row (cursor sequence field-types)
 631   (let* ((connection (postgresql-cursor-connection cursor))
 632          (socket (postgresql-connection-socket connection))
 633          (fields (postgresql-cursor-fields cursor)))
 634     (assert (= (length fields) (length sequence)))
 635     (loop
 636         (let ((code (read-socket-value 'int8 socket)))
 637           (case code
 638             (#.+ascii-row-message+
 639              (return
 640                #+ignore
 641                (let* ((count (length sequence))
 642                       (null-vector (read-null-bit-vector socket count)))
 643                  (dotimes (i count)
 644                    (declare (fixnum i))
 645                    (if (zerop (elt null-vector i))
 646                        (setf (elt sequence i) nil)
 647                        (let ((value (read-field socket (nth i field-types))))
 648                          (setf (elt sequence i) value)))))
 649                (map-into-indexed
 650                 sequence
 651                 #'(lambda (null-bit i)
 652                     (if (zerop null-bit)
 653                         nil
 654                         (read-field socket (nth i field-types))))
 655                 (read-null-bit-vector socket (length sequence)))))
 656             (#.+binary-row-message+
 657              (error "NYI"))
 658             (#.+completed-response-message+
 659              (return (values nil (read-socket-value 'string socket))))
 660             (#.+error-response-message+
 661              (let ((message (read-socket-value 'string socket)))
 662                (error 'postgresql-error
 663                       :connection connection :message message)))
 664             (#.+notice-response-message+
 665              (let ((message (read-socket-value 'string socket)))
 666                (warn 'postgresql-warning
 667                      :connection connection :message message)))
 668             (#.+notification-response-message+
 669              (let ((pid (read-socket-value 'int32 socket))
 670                    (message (read-socket-value 'string socket)))
 671                (when (= pid (postgresql-connection-pid connection))
 672                  (signal 'postgresql-notification :connection connection
 673                          :message message))))
 674             (t
 675              (close-postgresql-connection connection)
 676              (error 'postgresql-fatal-error :connection connection
 677                     :message "Received garbled message from backend")))))))
 678
 679 (defun skip-cursor-row (cursor)
 680   (let* ((connection (postgresql-cursor-connection cursor))
 681          (socket (postgresql-connection-socket connection))
 682          (fields (postgresql-cursor-fields cursor)))
 683     (loop
 684         (let ((code (read-socket-value 'int8 socket)))
 685           (case code
 686             (#.+ascii-row-message+
 687              (loop for null-bit across
 688                    (read-null-bit-vector socket (length fields))
 689                    do
 690                    (unless (zerop null-bit)
 691                      (let* ((length (read-socket-value 'int32 socket)))
 692                        (loop repeat (- length 4) do (read-byte socket)))))
 693              (return t))
 694             (#.+binary-row-message+
 695              (error "NYI"))
 696             (#.+completed-response-message+
 697              (return (values nil (read-socket-value 'string socket))))
 698             (#.+error-response-message+
 699              (let ((message (read-socket-value 'string socket)))
 700                (error 'postgresql-error
 701                       :connection connection :message message)))
 702             (#.+notice-response-message+
 703              (let ((message (read-socket-value 'string socket)))
 704                (warn 'postgresql-warning
 705                      :connection connection :message message)))
 706             (#.+notification-response-message+
 707              (let ((pid (read-socket-value 'int32 socket))
 708                    (message (read-socket-value 'string socket)))
 709                (when (= pid (postgresql-connection-pid connection))
 710                  (signal 'postgresql-notification :connection connection
 711                          :message message))))
 712             (t
 713              (close-postgresql-connection connection)
 714              (error 'postgresql-fatal-error :connection connection
 715                     :message "Received garbled message from backend")))))))
 716
 717 (defun run-query (connection query &optional (field-types nil))
 718   (start-query-execution connection query)
 719   (multiple-value-bind (status cursor)
 720       (wait-for-query-results connection)
 721     (assert (eq status :cursor))
 722     (loop for row = (read-cursor-row cursor field-types)
 723           while row
 724           collect row
 725           finally
 726           (wait-for-query-results connection))))