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