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