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   (asse
 564 rt (postgresql-connection-open-p connection))
 565   (let ((socket (postgresql-connection-socket connection))
 566         (cursor-name nil)
 567         (error nil))
 568     (loop
 569         (case (read-socket-value-int8 socket)
 570           (#.+completed-response-message+
 571            (return (values :completed (read-socket-value-string socket))))
 572           (#.+cursor-response-message+
 573            (setq cursor-name (read-socket-value-string socket)))
 574           (#.+row-description-message+
 575            (let* ((count (read-socket-value-int16 socket))
 576                   (fields
 577                    (loop repeat count
 578                      collect
 579                      (list
 580                       (read-socket-value-string socket)
 581                       (read-socket-value-int32 socket)
 582                       (read-socket-value-int16 socket)
 583                       (read-socket-value-int32 socket)))))
 584              (return
 585                (values :cursor
 586                        (make-postgresql-cursor :connection connection
 587                                                :name cursor-name
 588                                                :fields fields)))))
 589           (#.+copy-in-response-message+
 590            (return :copy-in))
 591           (#.+copy-out-response-message+
 592            (return :copy-out))
 593           (#.+ready-for-query-message+
 594            (when error
 595              (error error))
 596            (return nil))
 597           (#.+error-response-message+
 598            (let ((message (read-socket-value-string socket)))
 599              (setq error
 600                    (make-condition 'postgresql-error
 601                                    :connection connection :message message))))
 602           (#.+notice-response-message+
 603            (let ((message (read-socket-value-string socket)))
 604              (warn 'postgresql-warning
 605                    :connection connection :message message)))
 606           (#.+notification-response-message+
 607            (let ((pid (read-socket-value-int32 socket))
 608                  (message (read-socket-value-string socket)))
 609              (when (= pid (postgresql-connection-pid connection))
 610                (signal 'postgresql-notification :connection connection
 611                        :message message))))
 612           (t
 613            (close-postgresql-connection connection)
 614            (error 'postgresql-fatal-error :connection connection
 615                   :message "Received garbled message from backend"))))))
 616
 617 (defun read-null-bit-vector (socket count)
 618   (let ((result (make-array count :element-type 'bit)))
 619     (dotimes (offset (ceiling count 8))
 620       (loop with byte = (read-byte socket)
 621             for index from (* offset 8) below (min count (* (1+ offset) 8))
 622             for weight downfrom 7
 623             do (setf (aref result index) (ldb (byte 1 weight) byte))))
 624     result))
 625
 626
 627 (defun read-field (socket type)
 628   (let ((length (- (read-socket-value-int32 socket) 4)))
 629     (case type
 630       ((:int32 :int64)
 631        (read-integer-from-socket socket length))
 632       (:double
 633        (read-double-from-socket socket length))
 634       (t
 635        (let ((result (make-string length)))
 636          (read-socket-sequence result socket)
 637          result)))))
 638
 639 (uffi:def-constant +char-code-zero+ (char-code #\0))
 640 (uffi:def-constant +char-code-minus+ (char-code #\-))
 641 (uffi:def-constant +char-code-plus+ (char-code #\+))
 642 (uffi:def-constant +char-code-period+ (char-code #\.))
 643 (uffi:def-constant +char-code-lower-e+ (char-code #\e))
 644 (uffi:def-constant +char-code-upper-e+ (char-code #\E))
 645
 646 (defun read-integer-from-socket (socket length)
 647   (declare (fixnum length))
 648   (if (zerop length)
 649       nil
 650     (let ((val 0)
 651           (first-char (read-byte socket))
 652           (minusp nil))
 653       (declare (fixnum first-char))
 654       (decf length) ;; read first char
 655       (cond
 656        ((= first-char +char-code-minus+)
 657         (setq minusp t))
 658        ((= first-char +char-code-plus+)
 659         )               ;; nothing to do
 660        (t
 661         (setq val (- first-char +char-code-zero+))))
 662
 663       (dotimes (i length)
 664         (declare (fixnum i))
 665         (setq val (+
 666                    (* 10 val)
 667                    (- (read-byte socket) +char-code-zero+))))
 668       (if minusp
 669           (- val)
 670         val))))
 671
 672 (defmacro ascii-digit (int)
 673   (let ((offset (gensym)))
 674     `(let ((,offset (- ,int +char-code-zero+)))
 675       (declare (fixnum ,int ,offset))
 676       (if (and (>= ,offset 0)
 677                (< ,offset 10))
 678           ,offset
 679           nil))))
 680
 681 (defun read-double-from-socket (socket length)
 682   (declare (fixnum length))
 683   (let ((before-decimal 0)
 684         (after-decimal 0)
 685         (decimal-count 0)
 686         (exponent 0)
 687         (decimalp nil)
 688         (minusp nil)
 689         (result nil)
 690         (char (read-byte socket)))
 691     (declare (fixnum char exponent decimal-count))
 692     (decf length) ;; already read first character
 693     (cond
 694       ((= char +char-code-minus+)
 695        (setq minusp t))
 696       ((= char +char-code-plus+)
 697        )
 698       ((= char +char-code-period+)
 699        (setq decimalp t))
 700       (t
 701        (setq before-decimal (ascii-digit char))
 702        (unless before-decimal
 703          (error "Unexpected value"))))
 704
 705     (block loop
 706       (dotimes (i length)
 707         (setq char (read-byte socket))
 708         ;;      (format t "~&len:~D, i:~D, char:~D, minusp:~A, decimalp:~A" length i char minusp decimalp)
 709         (let ((weight (ascii-digit char)))
 710           (cond
 711            ((and weight (not decimalp)) ;; before decimal point
 712             (setq before-decimal (+ weight (* 10 before-decimal))))
 713            ((and weight decimalp) ;; after decimal point
 714             (setq after-decimal (+ weight (* 10 after-decimal)))
 715             (incf decimal-count))
 716            ((and (= char +char-code-period+))
 717             (setq decimalp t))
 718            ((or (= char +char-code-lower-e+)          ;; E is for exponent
 719                 (= char +char-code-upper-e+))
 720             (setq exponent (read-integer-from-socket socket (- length i 1)))
 721             (setq exponent (or exponent 0))
 722             (return-from loop))
 723           (t
 724            (break "Unexpected value"))
 725           )
 726         )))
 727     (setq result (* (+ (coerce before-decimal 'double-float)
 728                        (* after-decimal
 729                           (expt 10 (- decimal-count))))
 730                     (expt 10 exponent)))
 731     (if minusp
 732         (- result)
 733         result)))
 734
 735
 736 #+ignore
 737 (defun read-double-from-socket (socket length)
 738   (let ((result (make-string length)))
 739     (read-socket-sequence result socket)
 740     (let ((*read-default-float-format* 'double-float))
 741       (read-from-string result))))
 742
 743 (defun read-cursor-row (cursor types)
 744   (let* ((connection (postgresql-cursor-connection cursor))
 745          (socket (postgresql-connection-socket connection))
 746          (fields (postgresql-cursor-fields cursor)))
 747     (assert (postgresql-connection-open-p connection))
 748     (loop
 749         (let ((code (read-socket-value-int8 socket)))
 750           (case code
 751             (#.+ascii-row-message+
 752              (return
 753                (loop with count = (length fields)
 754                      with null-vector = (read-null-bit-vector socket count)
 755                      repeat count
 756                      for null-bit across null-vector
 757                      for i from 0
 758                      for null-p = (zerop null-bit)
 759                      if null-p
 760                      collect nil
 761                      else
 762                      collect
 763                      (read-field socket (nth i types)))))
 764             (#.+binary-row-message+
 765              (error "NYI"))
 766             (#.+completed-response-message+
 767              (return (values nil (read-socket-value-string socket))))
 768             (#.+error-response-message+
 769              (let ((message (read-socket-value-string socket)))
 770                (error 'postgresql-error
 771                       :connection connection :message message)))
 772             (#.+notice-response-message+
 773              (let ((message (read-socket-value-string socket)))
 774                (warn 'postgresql-warning
 775                      :connection connection :message message)))
 776             (#.+notification-response-message+
 777              (let ((pid (read-socket-value-int32 socket))
 778                    (message (read-socket-value-string socket)))
 779                (when (= pid (postgresql-connection-pid connection))
 780                  (signal 'postgresql-notification :connection connection
 781                          :message message))))
 782             (t
 783              (close-postgresql-connection connection)
 784              (error 'postgresql-fatal-error :connection connection
 785                     :message "Received garbled message from backend")))))))
 786
 787 (defun map-into-indexed (result-seq func seq)
 788   (dotimes (i (length seq))
 789     (declare (fixnum i))
 790     (setf (elt result-seq i)
 791           (funcall func (elt seq i) i)))
 792   result-seq)
 793
 794 (defun copy-cursor-row (cursor sequence types)
 795   (let* ((connection (postgresql-cursor-connection cursor))
 796          (socket (postgresql-connection-socket connection))
 797          (fields (postgresql-cursor-fields cursor)))
 798     (assert (= (length fields) (length sequence)))
 799     (loop
 800         (let ((code (read-socket-value-int8 socket)))
 801           (case code
 802             (#.+ascii-row-message+
 803              (return
 804                #+ignore
 805                (let* ((count (length sequence))
 806                       (null-vector (read-null-bit-vector socket count)))
 807                  (dotimes (i count)
 808                    (declare (fixnum i))
 809                    (if (zerop (elt null-vector i))
 810                        (setf (elt sequence i) nil)
 811                        (let ((value (read-field socket (nth i types))))
 812                          (setf (elt sequence i) value)))))
 813                (map-into-indexed
 814                 sequence
 815                 #'(lambda (null-bit i)
 816                     (if (zerop null-bit)
 817                         nil
 818                         (read-field socket (nth i types))))
 819                 (read-null-bit-vector socket (length sequence)))))
 820             (#.+binary-row-message+
 821              (error "NYI"))
 822             (#.+completed-response-message+
 823              (return (values nil (read-socket-value-string socket))))
 824             (#.+error-response-message+
 825              (let ((message (read-socket-value-string socket)))
 826                (error 'postgresql-error
 827                       :connection connection :message message)))
 828             (#.+notice-response-message+
 829              (let ((message (read-socket-value-string socket)))
 830                (warn 'postgresql-warning
 831                      :connection connection :message message)))
 832             (#.+notification-response-message+
 833              (let ((pid (read-socket-value-int32 socket))
 834                    (message (read-socket-value-string socket)))
 835                (when (= pid (postgresql-connection-pid connection))
 836                  (signal 'postgresql-notification :connection connection
 837                          :message message))))
 838             (t
 839              (close-postgresql-connection connection)
 840              (error 'postgresql-fatal-error :connection connection
 841                     :message "Received garbled message from backend")))))))
 842
 843 (defun skip-cursor-row (cursor)
 844   (let* ((connection (postgresql-cursor-connection cursor))
 845          (socket (postgresql-connection-socket connection))
 846          (fields (postgresql-cursor-fields cursor)))
 847     (loop
 848         (let ((code (read-socket-value-int8 socket)))
 849           (case code
 850             (#.+ascii-row-message+
 851              (loop for null-bit across
 852                    (read-null-bit-vector socket (length fields))
 853                    do
 854                    (unless (zerop null-bit)
 855                      (let* ((length (read-socket-value-int32 socket)))
 856                        (loop repeat (- length 4) do (read-byte socket)))))
 857              (return t))
 858             (#.+binary-row-message+
 859              (error "NYI"))
 860             (#.+completed-response-message+
 861              (return (values nil (read-socket-value-string socket))))
 862             (#.+error-response-message+
 863              (let ((message (read-socket-value-string socket)))
 864                (error 'postgresql-error
 865                       :connection connection :message message)))
 866             (#.+notice-response-message+
 867              (let ((message (read-socket-value-string socket)))
 868                (warn 'postgresql-warning
 869                      :connection connection :message message)))
 870             (#.+notification-response-message+
 871              (let ((pid (read-socket-value-int32 socket))
 872                    (message (read-socket-value-string socket)))
 873                (when (= pid (postgresql-connection-pid connection))
 874                  (signal 'postgresql-notification :connection connection
 875                          :message message))))
 876             (t
 877              (close-postgresql-connection connection)
 878              (error 'postgresql-fatal-error :connection connection
 879                     :message "Received garbled message from backend")))))))
 880
 881 (defun run-query (connection query &optional (result-types nil))
 882   (start-query-execution connection query)
 883   (multiple-value-bind (status cursor)
 884       (wait-for-query-results connection)
 885     (assert (eq status :cursor))
 886     (loop for row = (read-cursor-row cursor result-types)
 887           while row
 888           collect row
 889           finally
 890           (wait-for-query-results connection))))
 891
 892 #+scl
 893 (declaim (ext:maybe-inline read-byte write-byte))