db-postgresql-socket/postgresql-socket-api.lisp

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