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