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