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.3 2003/03/02 20:02:02 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 encrypt-md5 (plaintext salt)
 395   (string-downcase
 396    (format nil "~{~2,'0X~}"
 397            (coerce (md5:md5sum-sequence (concatenate 'string plaintext salt)) 'list))))
 398
 399 (defun reopen-postgresql-connection (connection)
 400   "Reopen the given PostgreSQL connection.  Closes any existing
 401 connection, if it is still open."
 402   (when (postgresql-connection-open-p connection)
 403     (close-postgresql-connection connection))
 404   (let ((socket (open-postgresql-socket-stream
 405                   (postgresql-connection-host connection)
 406                   (postgresql-connection-port connection))))
 407     (unwind-protect
 408          (progn
 409            (setf (postgresql-connection-socket connection) socket)
 410            (send-startup-message socket
 411                                  (postgresql-connection-database connection)
 412                                  (postgresql-connection-user connection)
 413                                  (postgresql-connection-options connection)
 414                                  (postgresql-connection-tty connection))
 415            (force-output socket)
 416            (loop
 417                (case (read-socket-value-int8 socket)
 418                  (#.+authentication-message+
 419                   (case (read-socket-value-int32 socket)
 420                     (0 (return))
 421                     ((1 2)
 422                      (error 'postgresql-login-error
 423                             :connection connection
 424                             :message
 425                             "Postmaster expects unsupported Kerberos authentication."))
 426                     (3
 427                      (send-unencrypted-password-message
 428                       socket
 429                       (postgresql-connection-password connection)))
 430                     (4
 431                      (let ((salt (make-string 2)))
 432                        (read-socket-sequence salt socket)
 433                        (send-encrypted-password-message
 434                         socket
 435                         (crypt-password
 436                          (postgresql-connection-password connection) salt))))
 437                     (5
 438                      (let ((salt (make-string 4)))
 439                        (read-socket-sequence salt socket)
 440                        (let* ((pwd2 (encrypt-md5 (postgresql-connection-password connection)
 441                                                  (postgresql-connection-user connection)))
 442                               (pwd (encrypt-md5 pwd2 salt)))
 443                          (send-encrypted-password-message
 444                           socket
 445                           (concatenate 'string "md5" pwd)))))
 446                     (t
 447                      (error 'postgresql-login-error
 448                             :connection connection
 449                             :message
 450                             "Postmaster expects unknown authentication method."))))
 451                  (#.+error-response-message+
 452                   (let ((message (read-socket-value-string socket)))
 453                     (error 'postgresql-login-error
 454                            :connection connection :message message)))
 455                  (t
 456                   (error 'postgresql-login-error
 457                          :connection connection
 458                          :message
 459                          "Received garbled message from Postmaster"))))
 460            ;; Start backend communication
 461            (force-output socket)
 462            (loop
 463                (case (read-socket-value-int8 socket)
 464                  (#.+backend-key-message+
 465                   (setf (postgresql-connection-pid connection)
 466                         (read-socket-value-int32 socket)
 467                         (postgresql-connection-key connection)
 468                         (read-socket-value-int32 socket)))
 469                  (#.+ready-for-query-message+
 470                   (setq socket nil)
 471                   (return connection))
 472                  (#.+error-response-message+
 473                   (let ((message (read-socket-value-string socket)))
 474                     (error 'postgresql-login-error
 475                            :connection connection
 476                            :message message)))
 477                  (#.+notice-response-message+
 478                   (let ((message (read-socket-value-string socket)))
 479                     (warn 'postgresql-warning :connection connection
 480                           :message message)))
 481                  (t
 482                   (error 'postgresql-login-error
 483                          :connection connection
 484                          :message
 485                          "Received garbled message from Postmaster")))))
 486       (when socket
 487         (close socket)))))
 488
 489 (defun close-postgresql-connection (connection &optional abort)
 490   (unless abort
 491     (ignore-errors
 492       (send-terminate-message (postgresql-connection-socket connection))))
 493   (close (postgresql-connection-socket connection)))
 494
 495 (defun postgresql-connection-open-p (connection)
 496   (let ((socket (postgresql-connection-socket connection)))
 497     (and socket (streamp socket) (open-stream-p socket))))
 498
 499 (defun ensure-open-postgresql-connection (connection)
 500   (unless (postgresql-connection-open-p connection)
 501     (reopen-postgresql-connection connection)))
 502
 503 (defun process-async-messages (connection)
 504   (assert (postgresql-connection-open-p connection))
 505   ;; Process any asnychronous messages
 506   (loop with socket = (postgresql-connection-socket connection)
 507         while (listen socket)
 508         do
 509         (case (read-socket-value-int8 socket)
 510           (#.+notice-response-message+
 511            (let ((message (read-socket-value-string socket)))
 512              (warn 'postgresql-warning :connection connection
 513                    :message message)))
 514           (#.+notification-response-message+
 515            (let ((pid (read-socket-value-int32 socket))
 516                  (message (read-socket-value-string socket)))
 517              (when (= pid (postgresql-connection-pid connection))
 518                (signal 'postgresql-notification :connection connection
 519                        :message message))))
 520           (t
 521            (close-postgresql-connection connection)
 522            (error 'postgresql-fatal-error :connection connection
 523                   :message "Received garbled message from backend")))))
 524
 525 (defun start-query-execution (connection query)
 526   (ensure-open-postgresql-connection connection)
 527   (process-async-messages connection)
 528   (send-query-message (postgresql-connection-socket connection) query)
 529   (force-output (postgresql-connection-socket connection)))
 530
 531 (defun wait-for-query-results (connection)
 532   (assert (postgresql-connection-open-p connection))
 533   (let ((socket (postgresql-connection-socket connection))
 534         (cursor-name nil)
 535         (error nil))
 536     (loop
 537         (case (read-socket-value-int8 socket)
 538           (#.+completed-response-message+
 539            (return (values :completed (read-socket-value-string socket))))
 540           (#.+cursor-response-message+
 541            (setq cursor-name (read-socket-value-string socket)))
 542           (#.+row-description-message+
 543            (let* ((count (read-socket-value-int16 socket))
 544                   (fields
 545                    (loop repeat count
 546                      collect
 547                      (list
 548                       (read-socket-value-string socket)
 549                       (read-socket-value-int32 socket)
 550                       (read-socket-value-int16 socket)
 551                       (read-socket-value-int32 socket)))))
 552              (return
 553                (values :cursor
 554                        (make-postgresql-cursor :connection connection
 555                                                :name cursor-name
 556                                                :fields fields)))))
 557           (#.+copy-in-response-message+
 558            (return :copy-in))
 559           (#.+copy-out-response-message+
 560            (return :copy-out))
 561           (#.+ready-for-query-message+
 562            (when error
 563              (error error))
 564            (return nil))
 565           (#.+error-response-message+
 566            (let ((message (read-socket-value-string socket)))
 567              (setq error
 568                    (make-condition 'postgresql-error
 569                                    :connection connection :message message))))
 570           (#.+notice-response-message+
 571            (let ((message (read-socket-value-string socket)))
 572              (warn 'postgresql-warning
 573                    :connection connection :message message)))
 574           (#.+notification-response-message+
 575            (let ((pid (read-socket-value-int32 socket))
 576                  (message (read-socket-value-string socket)))
 577              (when (= pid (postgresql-connection-pid connection))
 578                (signal 'postgresql-notification :connection connection
 579                        :message message))))
 580           (t
 581            (close-postgresql-connection connection)
 582            (error 'postgresql-fatal-error :connection connection
 583                   :message "Received garbled message from backend"))))))
 584
 585 (defun read-null-bit-vector (socket count)
 586   (let ((result (make-array count :element-type 'bit)))
 587     (dotimes (offset (ceiling count 8))
 588       (loop with byte = (read-byte socket)
 589             for index from (* offset 8) below (min count (* (1+ offset) 8))
 590             for weight downfrom 7
 591             do (setf (aref result index) (ldb (byte 1 weight) byte))))
 592     result))
 593
 594
 595 (defun read-field (socket type)
 596   (let ((length (- (read-socket-value-int32 socket) 4)))
 597     (case type
 598       ((:int32 :int64)
 599        (read-integer-from-socket socket length))
 600       (:double
 601        (read-double-from-socket socket length))
 602       (t
 603        (let ((result (make-string length)))
 604          (read-socket-sequence result socket)
 605          result)))))
 606
 607 (uffi:def-constant +char-code-zero+ (char-code #\0))
 608 (uffi:def-constant +char-code-minus+ (char-code #\-))
 609 (uffi:def-constant +char-code-plus+ (char-code #\+))
 610 (uffi:def-constant +char-code-period+ (char-code #\.))
 611 (uffi:def-constant +char-code-lower-e+ (char-code #\e))
 612 (uffi:def-constant +char-code-upper-e+ (char-code #\E))
 613
 614 (defun read-integer-from-socket (socket length)
 615   (declare (fixnum length))
 616   (if (zerop length)
 617       nil
 618     (let ((val 0)
 619           (first-char (read-byte socket))
 620           (minusp nil))
 621       (declare (fixnum first-char))
 622       (decf length) ;; read first char
 623       (cond
 624        ((= first-char +char-code-minus+)
 625         (setq minusp t))
 626        ((= first-char +char-code-plus+)
 627         )               ;; nothing to do
 628        (t
 629         (setq val (- first-char +char-code-zero+))))
 630
 631       (dotimes (i length)
 632         (declare (fixnum i))
 633         (setq val (+
 634                    (* 10 val)
 635                    (- (read-byte socket) +char-code-zero+))))
 636       (if minusp
 637           (- val)
 638         val))))
 639
 640 (defmacro ascii-digit (int)
 641   (let ((offset (gensym)))
 642     `(let ((,offset (- ,int +char-code-zero+)))
 643       (declare (fixnum ,int ,offset))
 644       (if (and (>= ,offset 0)
 645                (< ,offset 10))
 646           ,offset
 647           nil))))
 648
 649 (defun read-double-from-socket (socket length)
 650   (declare (fixnum length))
 651   (let ((before-decimal 0)
 652         (after-decimal 0)
 653         (decimal-count 0)
 654         (exponent 0)
 655         (decimalp nil)
 656         (minusp nil)
 657         (result nil)
 658         (char (read-byte socket)))
 659     (declare (fixnum char exponent decimal-count))
 660     (decf length) ;; already read first character
 661     (cond
 662       ((= char +char-code-minus+)
 663        (setq minusp t))
 664       ((= char +char-code-plus+)
 665        )
 666       ((= char +char-code-period+)
 667        (setq decimalp t))
 668       (t
 669        (setq before-decimal (ascii-digit char))
 670        (unless before-decimal
 671          (error "Unexpected value"))))
 672
 673     (block loop
 674       (dotimes (i length)
 675         (setq char (read-byte socket))
 676         ;;      (format t "~&len:~D, i:~D, char:~D, minusp:~A, decimalp:~A" length i char minusp decimalp)
 677         (let ((weight (ascii-digit char)))
 678           (cond
 679            ((and weight (not decimalp)) ;; before decimal point
 680             (setq before-decimal (+ weight (* 10 before-decimal))))
 681            ((and weight decimalp) ;; after decimal point
 682             (setq after-decimal (+ weight (* 10 after-decimal)))
 683             (incf decimal-count))
 684            ((and (= char +char-code-period+))
 685             (setq decimalp t))
 686            ((or (= char +char-code-lower-e+)          ;; E is for exponent
 687                 (= char +char-code-upper-e+))
 688             (setq exponent (read-integer-from-socket socket (- length i 1)))
 689             (setq exponent (or exponent 0))
 690             (return-from loop))
 691           (t
 692            (break "Unexpected value"))
 693           )
 694         )))
 695     (setq result (* (+ (coerce before-decimal 'double-float)
 696                        (* after-decimal
 697                           (expt 10 (- decimal-count))))
 698                     (expt 10 exponent)))
 699     (if minusp
 700         (- result)
 701         result)))
 702
 703
 704 #+ignore
 705 (defun read-double-from-socket (socket length)
 706   (let ((result (make-string length)))
 707     (read-socket-sequence result socket)
 708     (let ((*read-default-float-format* 'double-float))
 709       (read-from-string result))))
 710
 711 (defun read-cursor-row (cursor types)
 712   (let* ((connection (postgresql-cursor-connection cursor))
 713          (socket (postgresql-connection-socket connection))
 714          (fields (postgresql-cursor-fields cursor)))
 715     (assert (postgresql-connection-open-p connection))
 716     (loop
 717         (let ((code (read-socket-value-int8 socket)))
 718           (case code
 719             (#.+ascii-row-message+
 720              (return
 721                (loop with count = (length fields)
 722                      with null-vector = (read-null-bit-vector socket count)
 723                      repeat count
 724                      for null-bit across null-vector
 725                      for i from 0
 726                      for null-p = (zerop null-bit)
 727                      if null-p
 728                      collect nil
 729                      else
 730                      collect
 731                      (read-field socket (nth i types)))))
 732             (#.+binary-row-message+
 733              (error "NYI"))
 734             (#.+completed-response-message+
 735              (return (values nil (read-socket-value-string socket))))
 736             (#.+error-response-message+
 737              (let ((message (read-socket-value-string socket)))
 738                (error 'postgresql-error
 739                       :connection connection :message message)))
 740             (#.+notice-response-message+
 741              (let ((message (read-socket-value-string socket)))
 742                (warn 'postgresql-warning
 743                      :connection connection :message message)))
 744             (#.+notification-response-message+
 745              (let ((pid (read-socket-value-int32 socket))
 746                    (message (read-socket-value-string socket)))
 747                (when (= pid (postgresql-connection-pid connection))
 748                  (signal 'postgresql-notification :connection connection
 749                          :message message))))
 750             (t
 751              (close-postgresql-connection connection)
 752              (error 'postgresql-fatal-error :connection connection
 753                     :message "Received garbled message from backend")))))))
 754
 755 (defun map-into-indexed (result-seq func seq)
 756   (dotimes (i (length seq))
 757     (declare (fixnum i))
 758     (setf (elt result-seq i)
 759           (funcall func (elt seq i) i)))
 760   result-seq)
 761
 762 (defun copy-cursor-row (cursor sequence types)
 763   (let* ((connection (postgresql-cursor-connection cursor))
 764          (socket (postgresql-connection-socket connection))
 765          (fields (postgresql-cursor-fields cursor)))
 766     (assert (= (length fields) (length sequence)))
 767     (loop
 768         (let ((code (read-socket-value-int8 socket)))
 769           (case code
 770             (#.+ascii-row-message+
 771              (return
 772                #+ignore
 773                (let* ((count (length sequence))
 774                       (null-vector (read-null-bit-vector socket count)))
 775                  (dotimes (i count)
 776                    (declare (fixnum i))
 777                    (if (zerop (elt null-vector i))
 778                        (setf (elt sequence i) nil)
 779                        (let ((value (read-field socket (nth i types))))
 780                          (setf (elt sequence i) value)))))
 781                (map-into-indexed
 782                 sequence
 783                 #'(lambda (null-bit i)
 784                     (if (zerop null-bit)
 785                         nil
 786                         (read-field socket (nth i types))))
 787                 (read-null-bit-vector socket (length sequence)))))
 788             (#.+binary-row-message+
 789              (error "NYI"))
 790             (#.+completed-response-message+
 791              (return (values nil (read-socket-value-string socket))))
 792             (#.+error-response-message+
 793              (let ((message (read-socket-value-string socket)))
 794                (error 'postgresql-error
 795                       :connection connection :message message)))
 796             (#.+notice-response-message+
 797              (let ((message (read-socket-value-string socket)))
 798                (warn 'postgresql-warning
 799                      :connection connection :message message)))
 800             (#.+notification-response-message+
 801              (let ((pid (read-socket-value-int32 socket))
 802                    (message (read-socket-value-string socket)))
 803                (when (= pid (postgresql-connection-pid connection))
 804                  (signal 'postgresql-notification :connection connection
 805                          :message message))))
 806             (t
 807              (close-postgresql-connection connection)
 808              (error 'postgresql-fatal-error :connection connection
 809                     :message "Received garbled message from backend")))))))
 810
 811 (defun skip-cursor-row (cursor)
 812   (let* ((connection (postgresql-cursor-connection cursor))
 813          (socket (postgresql-connection-socket connection))
 814          (fields (postgresql-cursor-fields cursor)))
 815     (loop
 816         (let ((code (read-socket-value-int8 socket)))
 817           (case code
 818             (#.+ascii-row-message+
 819              (loop for null-bit across
 820                    (read-null-bit-vector socket (length fields))
 821                    do
 822                    (unless (zerop null-bit)
 823                      (let* ((length (read-socket-value-int32 socket)))
 824                        (loop repeat (- length 4) do (read-byte socket)))))
 825              (return t))
 826             (#.+binary-row-message+
 827              (error "NYI"))
 828             (#.+completed-response-message+
 829              (return (values nil (read-socket-value-string socket))))
 830             (#.+error-response-message+
 831              (let ((message (read-socket-value-string socket)))
 832                (error 'postgresql-error
 833                       :connection connection :message message)))
 834             (#.+notice-response-message+
 835              (let ((message (read-socket-value-string socket)))
 836                (warn 'postgresql-warning
 837                      :connection connection :message message)))
 838             (#.+notification-response-message+
 839              (let ((pid (read-socket-value-int32 socket))
 840                    (message (read-socket-value-string socket)))
 841                (when (= pid (postgresql-connection-pid connection))
 842                  (signal 'postgresql-notification :connection connection
 843                          :message message))))
 844             (t
 845              (close-postgresql-connection connection)
 846              (error 'postgresql-fatal-error :connection connection
 847                     :message "Received garbled message from backend")))))))
 848
 849 (defun run-query (connection query &optional (types nil))
 850   (start-query-execution connection query)
 851   (multiple-value-bind (status cursor)
 852       (wait-for-query-results connection)
 853     (assert (eq status :cursor))
 854     (loop for row = (read-cursor-row cursor types)
 855           while row
 856           collect row
 857           finally
 858           (wait-for-query-results connection))))
 859
 860 #+scl
 861 (declaim (ext:maybe-inline read-byte write-byte))