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-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-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-toplevel :load-toplevel :execute)
 218   (defvar *crypt-library-loaded* nil)
 219
 220   (unless *crypt-library-loaded*
 221     (uffi:load-foreign-library
 222      (uffi:find-foreign-library "libcrypt"
 223                            '(#+64bit "/usr/lib64/"
 224                              "/usr/lib/" "/usr/local/lib/" "/lib/"))
 225      :supporting-libraries '("c"))
 226     (setq *crypt-library-loaded* t)))
 227
 228 (in-package :postgresql-socket)
 229
 230 (uffi:def-function ("crypt" crypt)
 231     ((key :cstring)
 232      (salt :cstring))
 233   :returning :cstring)
 234
 235 (defun crypt-password (password salt)
 236   "Encrypt a password for transmission to a PostgreSQL server."
 237   (uffi:with-cstring (password-cstring password)
 238     (uffi:with-cstring (salt-cstring salt)
 239       (uffi:convert-from-cstring
 240        (crypt password-cstring salt-cstring)))))
 241
 242 \f
 243 ;;;; Condition hierarchy
 244
 245 (define-condition postgresql-condition (condition)
 246   ((connection :initarg :connection :reader postgresql-condition-connection)
 247    (message :initarg :message :reader postgresql-condition-message))
 248   (:report
 249    (lambda (c stream)
 250      (format stream "~@<~A occurred on connection ~A. ~:@_Reason: ~A~:@>"
 251              (type-of c)
 252              (postgresql-condition-connection c)
 253              (postgresql-condition-message c)))))
 254
 255 (define-condition postgresql-error (error postgresql-condition)
 256   ())
 257
 258 (define-condition postgresql-fatal-error (postgresql-error)
 259   ())
 260
 261 (define-condition postgresql-login-error (postgresql-fatal-error)
 262   ())
 263
 264 (define-condition postgresql-warning (warning postgresql-condition)
 265   ())
 266
 267 (define-condition postgresql-notification (postgresql-condition)
 268   ()
 269   (:report
 270    (lambda (c stream)
 271      (format stream "~@<Asynchronous notification on connection ~A: ~:@_~A~:@>"
 272              (postgresql-condition-connection c)
 273              (postgresql-condition-message c)))))
 274
 275 ;;; Structures
 276
 277 (defstruct postgresql-connection
 278   host
 279   port
 280   database
 281   user
 282   password
 283   options
 284   tty
 285   socket
 286   pid
 287   key)
 288
 289 (defstruct postgresql-cursor
 290   connection
 291   name
 292   fields)
 293
 294 ;;; Socket stuff
 295
 296 (defconstant +postgresql-server-default-port+ 5432
 297   "Default port of PostgreSQL server.")
 298
 299 (defvar *postgresql-server-socket-timeout* 60
 300   "Timeout in seconds for reads from the PostgreSQL server.")
 301
 302 #+(or cmu scl)
 303 (defun open-postgresql-socket (host port)
 304   (etypecase host
 305     (pathname
 306      ;; Directory to unix-domain socket
 307      (ext:connect-to-unix-socket
 308       (namestring
 309        (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
 310                       :defaults host))))
 311     (string
 312      (ext:connect-to-inet-socket host port))))
 313
 314 #+sbcl
 315 (defun open-postgresql-socket (host port)
 316   (etypecase host
 317     (pathname
 318      ;; Directory to unix-domain socket
 319      (sb-bsd-sockets:socket-connect
 320       (namestring
 321        (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
 322                       :defaults host))))
 323     (string
 324      (let ((sock (make-instance 'sb-bsd-sockets:inet-socket
 325                                 :type :stream
 326                                 :protocol :tcp)))
 327        (sb-bsd-sockets:socket-connect
 328         sock
 329         (sb-bsd-sockets:host-ent-address
 330          (sb-bsd-sockets:get-host-by-name host))
 331         port)
 332        sock))))
 333
 334 #+(or cmu scl)
 335 (defun open-postgresql-socket-stream (host port)
 336   (system:make-fd-stream
 337    (open-postgresql-socket host port)
 338    :input t :output t :element-type '(unsigned-byte 8)
 339    :buffering :none
 340    :timeout *postgresql-server-socket-timeout*))
 341
 342
 343 #+sbcl
 344 (defun open-postgresql-socket-stream (host port)
 345   (sb-bsd-sockets:socket-make-stream
 346    (open-postgresql-socket host port) :input t :output t
 347    :element-type '(unsigned-byte 8)))
 348
 349
 350 #+allegro
 351 (defun open-postgresql-socket-stream (host port)
 352   (etypecase host
 353     (pathname
 354      (let ((path (namestring
 355                   (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
 356                                  :defaults host))))
 357        (socket:make-socket :type :stream :address-family :file
 358                            :connect :active
 359                            :remote-filename path :local-filename path)))
 360     (string
 361      (socket:with-pending-connect
 362          (mp:with-timeout (*postgresql-server-socket-timeout* (error "connect failed"))
 363            (socket:make-socket :type :stream :address-family :internet
 364                                :remote-port port :remote-host host
 365                                :connect :active :nodelay t))))))
 366
 367 #+openmcl
 368 (defun open-postgresql-socket-stream (host port)
 369   (etypecase host
 370     (pathname
 371      (let ((path (namestring
 372                   (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
 373                                  :defaults host))))
 374        (ccl:make-socket :type :stream :address-family :file
 375                         :connect :active
 376                         :remote-filename path :local-filename path)))
 377     (string
 378      (ccl:make-socket :type :stream :address-family :internet
 379                       :remote-port port :remote-host host
 380                       :connect :active :nodelay t))))
 381
 382 #+lispworks
 383 (defun open-postgresql-socket-stream (host port)
 384   (etypecase host
 385     (pathname
 386      (error "File sockets not supported on Lispworks."))
 387     (string
 388      (comm:open-tcp-stream host port :direction :io :element-type '(unsigned-byte 8)
 389                            :read-timeout *postgresql-server-socket-timeout*))
 390     ))
 391
 392 ;;; Interface Functions
 393
 394 (defun open-postgresql-connection (&key (host (cmucl-compat:required-argument))
 395                                         (port +postgresql-server-default-port+)
 396                                         (database (cmucl-compat:required-argument))
 397                                         (user (cmucl-compat:required-argument))
 398                                         options tty password)
 399   "Open a connection to a PostgreSQL server with the given parameters.
 400 Note that host, database and user arguments must be supplied.
 401
 402 If host is a pathname, it is assumed to name a directory containing
 403 the local unix-domain sockets of the server, with port selecting which
 404 of those sockets to open.  If host is a string, it is assumed to be
 405 the name of the host running the PostgreSQL server.  In that case a
 406 TCP connection to the given port on that host is opened in order to
 407 communicate with the server.  In either case the port argument
 408 defaults to `+postgresql-server-default-port+'.
 409
 410 Password is the clear-text password to be passed in the authentication
 411 phase to the server.  Depending on the server set-up, it is either
 412 passed in the clear, or encrypted via crypt and a server-supplied
 413 salt.  In that case the alien function specified by `*crypt-library*'
 414 and `*crypt-function-name*' is used for encryption.
 415
 416 Note that all the arguments (including the clear-text password
 417 argument) are stored in the `postgresql-connection' structure, in
 418 order to facilitate automatic reconnection in case of communication
 419 troubles."
 420   (reopen-postgresql-connection
 421    (make-postgresql-connection :host host :port port
 422                                :options (or options "") :tty (or tty "")
 423                                :database database :user user
 424                                :password (or password ""))))
 425
 426 (defun encrypt-md5 (plaintext salt)
 427   (string-downcase
 428    (format nil "~{~2,'0X~}"
 429            (coerce (md5sum-sequence (concatenate 'string plaintext salt)) 'list))))
 430
 431 (defun reopen-postgresql-connection (connection)
 432   "Reopen the given PostgreSQL connection.  Closes any existing
 433 connection, if it is still open."
 434   (when (postgresql-connection-open-p connection)
 435     (close-postgresql-connection connection))
 436   (let ((socket (open-postgresql-socket-stream
 437                   (postgresql-connection-host connection)
 438                   (postgresql-connection-port connection))))
 439     (unwind-protect
 440          (progn
 441            (setf (postgresql-connection-socket connection) socket)
 442            (send-startup-message socket
 443                                  (postgresql-connection-database connection)
 444                                  (postgresql-connection-user connection)
 445                                  (postgresql-connection-options connection)
 446                                  (postgresql-connection-tty connection))
 447            (force-output socket)
 448            (loop
 449                (case (read-socket-value-int8 socket)
 450                  (#.+authentication-message+
 451                   (case (read-socket-value-int32 socket)
 452                     (0 (return))
 453                     ((1 2)
 454                      (error 'postgresql-login-error
 455                             :connection connection
 456                             :message
 457                             "Postmaster expects unsupported Kerberos authentication."))
 458                     (3
 459                      (send-unencrypted-password-message
 460                       socket
 461                       (postgresql-connection-password connection))
 462                       (force-output socket))
 463                     (4
 464                      (let ((salt (make-string 2)))
 465                        (read-socket-sequence salt socket)
 466                        (send-encrypted-password-message
 467                         socket
 468                         (crypt-password
 469                          (postgresql-connection-password connection) salt)))
 470                      (force-output socket))
 471                     (5
 472                      (let ((salt (make-string 4)))
 473                        (read-socket-sequence salt socket)
 474                        (let* ((pwd2 (encrypt-md5 (postgresql-connection-password connection)
 475                                                  (postgresql-connection-user connection)))
 476                               (pwd (encrypt-md5 pwd2 salt)))
 477                          (send-encrypted-password-message
 478                           socket
 479                           (concatenate 'string "md5" pwd))))
 480                      (force-output socket))
 481                     (t
 482                      (error 'postgresql-login-error
 483                             :connection connection
 484                             :message
 485                             "Postmaster expects unknown authentication method."))))
 486                  (#.+error-response-message+
 487                   (let ((message (read-socket-value-string socket)))
 488                     (error 'postgresql-login-error
 489                            :connection connection :message message)))
 490                  (t
 491                   (error 'postgresql-login-error
 492                          :connection connection
 493                          :message
 494                          "Received garbled message from Postmaster"))))
 495            ;; Start backend communication
 496            (force-output socket)
 497            (loop
 498                (case (read-socket-value-int8 socket)
 499                  (#.+backend-key-message+
 500                   (setf (postgresql-connection-pid connection)
 501                         (read-socket-value-int32 socket)
 502                         (postgresql-connection-key connection)
 503                         (read-socket-value-int32 socket)))
 504                  (#.+ready-for-query-message+
 505                   (setq socket nil)
 506                   (return connection))
 507                  (#.+error-response-message+
 508                   (let ((message (read-socket-value-string socket)))
 509                     (error 'postgresql-login-error
 510                            :connection connection
 511                            :message message)))
 512                  (#.+notice-response-message+
 513                   (let ((message (read-socket-value-string socket)))
 514                     (warn 'postgresql-warning :connection connection
 515                           :message message)))
 516                  (t
 517                   (error 'postgresql-login-error
 518                          :connection connection
 519                          :message
 520                          "Received garbled message from Postmaster")))))
 521       (when socket
 522         (close socket)))))
 523
 524 (defun close-postgresql-connection (connection &optional abort)
 525   (unless abort
 526     (ignore-errors
 527       (send-terminate-message (postgresql-connection-socket connection))))
 528   (close (postgresql-connection-socket connection)))
 529
 530 (defun postgresql-connection-open-p (connection)
 531   (let ((socket (postgresql-connection-socket connection)))
 532     (and socket (streamp socket) (open-stream-p socket))))
 533
 534 (defun ensure-open-postgresql-connection (connection)
 535   (unless (postgresql-connection-open-p connection)
 536     (reopen-postgresql-connection connection)))
 537
 538 (defun process-async-messages (connection)
 539   (assert (postgresql-connection-open-p connection))
 540   ;; Process any asnychronous messages
 541   (loop with socket = (postgresql-connection-socket connection)
 542         while (listen socket)
 543         do
 544         (case (read-socket-value-int8 socket)
 545           (#.+notice-response-message+
 546            (let ((message (read-socket-value-string socket)))
 547              (warn 'postgresql-warning :connection connection
 548                    :message message)))
 549           (#.+notification-response-message+
 550            (let ((pid (read-socket-value-int32 socket))
 551                  (message (read-socket-value-string socket)))
 552              (when (= pid (postgresql-connection-pid connection))
 553                (signal 'postgresql-notification :connection connection
 554                        :message message))))
 555           (t
 556            (close-postgresql-connection connection)
 557            (error 'postgresql-fatal-error :connection connection
 558                   :message "Received garbled message from backend")))))
 559
 560 (defun start-query-execution (connection query)
 561   (ensure-open-postgresql-connection connection)
 562   (process-async-messages connection)
 563   (send-query-message (postgresql-connection-socket connection) query)
 564   (force-output (postgresql-connection-socket connection)))
 565
 566 (defun wait-for-query-results (connection)
 567   (assert (postgresql-connection-open-p connection))
 568   (let ((socket (postgresql-connection-socket connection))
 569         (cursor-name nil)
 570         (error nil))
 571     (loop
 572         (case (read-socket-value-int8 socket)
 573           (#.+completed-response-message+
 574            (return (values :completed (read-socket-value-string socket))))
 575           (#.+cursor-response-message+
 576            (setq cursor-name (read-socket-value-string socket)))
 577           (#.+row-description-message+
 578            (let* ((count (read-socket-value-int16 socket))
 579                   (fields
 580                    (loop repeat count
 581                      collect
 582                      (list
 583                       (read-socket-value-string socket)
 584                       (read-socket-value-int32 socket)
 585                       (read-socket-value-int16 socket)
 586                       (read-socket-value-int32 socket)))))
 587              (return
 588                (values :cursor
 589                        (make-postgresql-cursor :connection connection
 590                                                :name cursor-name
 591                                                :fields fields)))))
 592           (#.+copy-in-response-message+
 593            (return :copy-in))
 594           (#.+copy-out-response-message+
 595            (return :copy-out))
 596           (#.+ready-for-query-message+
 597            (when error
 598              (error error))
 599            (return nil))
 600           (#.+error-response-message+
 601            (let ((message (read-socket-value-string socket)))
 602              (setq error
 603                    (make-condition 'postgresql-error
 604                                    :connection connection :message message))))
 605           (#.+notice-response-message+
 606            (let ((message (read-socket-value-string socket)))
 607              (unless (eq :ignore clsql-sys:*backend-warning-behavior*)
 608                (warn 'postgresql-warning
 609                      :connection connection :message message))))
 610           (#.+notification-response-message+
 611            (let ((pid (read-socket-value-int32 socket))
 612                  (message (read-socket-value-string socket)))
 613              (when (= pid (postgresql-connection-pid connection))
 614                (signal 'postgresql-notification :connection connection
 615                        :message message))))
 616           (t
 617            (close-postgresql-connection connection)
 618            (error 'postgresql-fatal-error :connection connection
 619                   :message "Received garbled message from backend"))))))
 620
 621 (defun read-null-bit-vector (socket count)
 622   (let ((result (make-array count :element-type 'bit)))
 623     (dotimes (offset (ceiling count 8))
 624       (loop with byte = (read-byte socket)
 625             for index from (* offset 8) below (min count (* (1+ offset) 8))
 626             for weight downfrom 7
 627             do (setf (aref result index) (ldb (byte 1 weight) byte))))
 628     result))
 629
 630
 631 (defun read-field (socket type)
 632   (let ((length (- (read-socket-value-int32 socket) 4)))
 633     (case type
 634       ((:int32 :int64)
 635        (read-integer-from-socket socket length))
 636       (:double
 637        (read-double-from-socket socket length))
 638       (t
 639        (let ((result (make-string length)))
 640          (read-socket-sequence result socket)
 641          result)))))
 642
 643 (uffi:def-constant +char-code-zero+ (char-code #\0))
 644 (uffi:def-constant +char-code-minus+ (char-code #\-))
 645 (uffi:def-constant +char-code-plus+ (char-code #\+))
 646 (uffi:def-constant +char-code-period+ (char-code #\.))
 647 (uffi:def-constant +char-code-lower-e+ (char-code #\e))
 648 (uffi:def-constant +char-code-upper-e+ (char-code #\E))
 649
 650 (defun read-integer-from-socket (socket length)
 651   (declare (fixnum length))
 652   (if (zerop length)
 653       nil
 654     (let ((val 0)
 655           (first-char (read-byte socket))
 656           (minusp nil))
 657       (declare (fixnum first-char))
 658       (decf length) ;; read first char
 659       (cond
 660        ((= first-char +char-code-minus+)
 661         (setq minusp t))
 662        ((= first-char +char-code-plus+)
 663         )               ;; nothing to do
 664        (t
 665         (setq val (- first-char +char-code-zero+))))
 666
 667       (dotimes (i length)
 668         (declare (fixnum i))
 669         (setq val (+
 670                    (* 10 val)
 671                    (- (read-byte socket) +char-code-zero+))))
 672       (if minusp
 673           (- val)
 674         val))))
 675
 676 (defmacro ascii-digit (int)
 677   (let ((offset (gensym)))
 678     `(let ((,offset (- ,int +char-code-zero+)))
 679       (declare (fixnum ,int ,offset))
 680       (if (and (>= ,offset 0)
 681                (< ,offset 10))
 682           ,offset
 683           nil))))
 684
 685 (defun read-double-from-socket (socket length)
 686   (declare (fixnum length))
 687   (let ((before-decimal 0)
 688         (after-decimal 0)
 689         (decimal-count 0)
 690         (exponent 0)
 691         (decimalp nil)
 692         (minusp nil)
 693         (result nil)
 694         (char (read-byte socket)))
 695     (declare (fixnum char exponent decimal-count))
 696     (decf length) ;; already read first character
 697     (cond
 698       ((= char +char-code-minus+)
 699        (setq minusp t))
 700       ((= char +char-code-plus+)
 701        )
 702       ((= char +char-code-period+)
 703        (setq decimalp t))
 704       (t
 705        (setq before-decimal (ascii-digit char))
 706        (unless before-decimal
 707          (error "Unexpected value"))))
 708
 709     (block loop
 710       (dotimes (i length)
 711         (setq char (read-byte socket))
 712         ;;      (format t "~&len:~D, i:~D, char:~D, minusp:~A, decimalp:~A" length i char minusp decimalp)
 713         (let ((weight (ascii-digit char)))
 714           (cond
 715            ((and weight (not decimalp)) ;; before decimal point
 716             (setq before-decimal (+ weight (* 10 before-decimal))))
 717            ((and weight decimalp) ;; after decimal point
 718             (setq after-decimal (+ weight (* 10 after-decimal)))
 719             (incf decimal-count))
 720            ((and (= char +char-code-period+))
 721             (setq decimalp t))
 722            ((or (= char +char-code-lower-e+)          ;; E is for exponent
 723                 (= char +char-code-upper-e+))
 724             (setq exponent (read-integer-from-socket socket (- length i 1)))
 725             (setq exponent (or exponent 0))
 726             (return-from loop))
 727           (t
 728            (break "Unexpected value"))
 729           )
 730         )))
 731     (setq result (* (+ (coerce before-decimal 'double-float)
 732                        (* after-decimal
 733                           (expt 10 (- decimal-count))))
 734                     (expt 10 exponent)))
 735     (if minusp
 736         (- result)
 737         result)))
 738
 739
 740 #+ignore
 741 (defun read-double-from-socket (socket length)
 742   (let ((result (make-string length)))
 743     (read-socket-sequence result socket)
 744     (let ((*read-default-float-format* 'double-float))
 745       (read-from-string result))))
 746
 747 (defun read-cursor-row (cursor types)
 748   (let* ((connection (postgresql-cursor-connection cursor))
 749          (socket (postgresql-connection-socket connection))
 750          (fields (postgresql-cursor-fields cursor)))
 751     (assert (postgresql-connection-open-p connection))
 752     (loop
 753         (let ((code (read-socket-value-int8 socket)))
 754           (case code
 755             (#.+ascii-row-message+
 756              (return
 757                (loop with count = (length fields)
 758                      with null-vector = (read-null-bit-vector socket count)
 759                      repeat count
 760                      for null-bit across null-vector
 761                      for i from 0
 762                      for null-p = (zerop null-bit)
 763                      if null-p
 764                      collect nil
 765                      else
 766                      collect
 767                      (read-field socket (nth i types)))))
 768             (#.+binary-row-message+
 769              (error "NYI"))
 770             (#.+completed-response-message+
 771              (return (values nil (read-socket-value-string socket))))
 772             (#.+error-response-message+
 773              (let ((message (read-socket-value-string socket)))
 774                (error 'postgresql-error
 775                       :connection connection :message message)))
 776             (#.+notice-response-message+
 777              (let ((message (read-socket-value-string socket)))
 778                (warn 'postgresql-warning
 779                      :connection connection :message message)))
 780             (#.+notification-response-message+
 781              (let ((pid (read-socket-value-int32 socket))
 782                    (message (read-socket-value-string socket)))
 783                (when (= pid (postgresql-connection-pid connection))
 784                  (signal 'postgresql-notification :connection connection
 785                          :message message))))
 786             (t
 787              (close-postgresql-connection connection)
 788              (error 'postgresql-fatal-error :connection connection
 789                     :message "Received garbled message from backend")))))))
 790
 791 (defun map-into-indexed (result-seq func seq)
 792   (dotimes (i (length seq))
 793     (declare (fixnum i))
 794     (setf (elt result-seq i)
 795           (funcall func (elt seq i) i)))
 796   result-seq)
 797
 798 (defun copy-cursor-row (cursor sequence types)
 799   (let* ((connection (postgresql-cursor-connection cursor))
 800          (socket (postgresql-connection-socket connection))
 801          (fields (postgresql-cursor-fields cursor)))
 802     (assert (= (length fields) (length sequence)))
 803     (loop
 804         (let ((code (read-socket-value-int8 socket)))
 805           (case code
 806             (#.+ascii-row-message+
 807              (return
 808                #+ignore
 809                (let* ((count (length sequence))
 810                       (null-vector (read-null-bit-vector socket count)))
 811                  (dotimes (i count)
 812                    (declare (fixnum i))
 813                    (if (zerop (elt null-vector i))
 814                        (setf (elt sequence i) nil)
 815                        (let ((value (read-field socket (nth i types))))
 816                          (setf (elt sequence i) value)))))
 817                (map-into-indexed
 818                 sequence
 819                 #'(lambda (null-bit i)
 820                     (if (zerop null-bit)
 821                         nil
 822                         (read-field socket (nth i types))))
 823                 (read-null-bit-vector socket (length sequence)))))
 824             (#.+binary-row-message+
 825              (error "NYI"))
 826             (#.+completed-response-message+
 827              (return (values nil (read-socket-value-string socket))))
 828             (#.+error-response-message+
 829              (let ((message (read-socket-value-string socket)))
 830                (error 'postgresql-error
 831                       :connection connection :message message)))
 832             (#.+notice-response-message+
 833              (let ((message (read-socket-value-string socket)))
 834                (warn 'postgresql-warning
 835                      :connection connection :message message)))
 836             (#.+notification-response-message+
 837              (let ((pid (read-socket-value-int32 socket))
 838                    (message (read-socket-value-string socket)))
 839                (when (= pid (postgresql-connection-pid connection))
 840                  (signal 'postgresql-notification :connection connection
 841                          :message message))))
 842             (t
 843              (close-postgresql-connection connection)
 844              (error 'postgresql-fatal-error :connection connection
 845                     :message "Received garbled message from backend")))))))
 846
 847 (defun skip-cursor-row (cursor)
 848   (let* ((connection (postgresql-cursor-connection cursor))
 849          (socket (postgresql-connection-socket connection))
 850          (fields (postgresql-cursor-fields cursor)))
 851     (loop
 852         (let ((code (read-socket-value-int8 socket)))
 853           (case code
 854             (#.+ascii-row-message+
 855              (loop for null-bit across
 856                    (read-null-bit-vector socket (length fields))
 857                    do
 858                    (unless (zerop null-bit)
 859                      (let* ((length (read-socket-value-int32 socket)))
 860                        (loop repeat (- length 4) do (read-byte socket)))))
 861              (return t))
 862             (#.+binary-row-message+
 863              (error "NYI"))
 864             (#.+completed-response-message+
 865              (return (values nil (read-socket-value-string socket))))
 866             (#.+error-response-message+
 867              (let ((message (read-socket-value-string socket)))
 868                (error 'postgresql-error
 869                       :connection connection :message message)))
 870             (#.+notice-response-message+
 871              (let ((message (read-socket-value-string socket)))
 872                (warn 'postgresql-warning
 873                      :connection connection :message message)))
 874             (#.+notification-response-message+
 875              (let ((pid (read-socket-value-int32 socket))
 876                    (message (read-socket-value-string socket)))
 877                (when (= pid (postgresql-connection-pid connection))
 878                  (signal 'postgresql-notification :connection connection
 879                          :message message))))
 880             (t
 881              (close-postgresql-connection connection)
 882              (error 'postgresql-fatal-error :connection connection
 883                     :message "Received garbled message from backend")))))))
 884
 885 (defun run-query (connection query &optional (result-types nil))
 886   (start-query-execution connection query)
 887   (multiple-value-bind (status cursor)
 888       (wait-for-query-results connection)
 889     (assert (eq status :cursor))
 890     (loop for row = (read-cursor-row cursor result-types)
 891           while row
 892           collect row
 893           finally
 894           (wait-for-query-results connection))))
 895
 896 #+scl
 897 (declaim (ext:maybe-inline read-byte write-byte))