cl-postgres/communicate.lisp

   1 (in-package :cl-postgres)
   2
   3 ;; These are used to synthesize reader and writer names for integer
   4 ;; reading/writing functions when the amount of bytes and the
   5 ;; signedness is known. Both the macro that creates the functions and
   6 ;; some macros that use them create names this way.
   7 (eval-when (:compile-toplevel :load-toplevel :execute)
   8   (defun integer-reader-name (bytes signed)
   9     (intern (with-standard-io-syntax
  10               (format nil "~a~a~a~a" '#:read- (if signed "" '#:u) '#:int bytes))))
  11   (defun integer-writer-name (bytes signed)
  12     (intern (with-standard-io-syntax
  13               (format nil "~a~a~a~a" '#:write- (if signed "" '#:u) '#:int bytes)))))
  14
  15 (defmacro integer-reader (bytes)
  16   "Create a function to read integers from a binary stream."
  17   (let ((bits (* bytes 8)))
  18     (labels ((return-form (signed)
  19                (if signed
  20                    `(if (logbitp ,(1- bits) result)
  21                         (dpb result (byte ,(1- bits) 0) -1)
  22                         result)
  23                    `result))
  24              (generate-reader (signed)
  25                `(defun ,(integer-reader-name bytes signed) (socket)
  26                   (declare (type stream socket)
  27                            #.*optimize*)
  28                   ,(if (= bytes 1)
  29                        `(let ((result (the (unsigned-byte 8) (read-byte socket))))
  30                           (declare (type (unsigned-byte 8) result))
  31                           ,(return-form signed))
  32                        `(let ((result 0))
  33                           (declare (type (unsigned-byte ,bits) result))
  34                           ,@(loop :for byte :from (1- bytes) :downto 0
  35                                    :collect `(setf (ldb (byte 8 ,(* 8 byte)) result)
  36                                                    (the (unsigned-byte 8) (read-byte socket))))
  37                           ,(return-form signed))))))
  38       `(progn
  39 ;; This causes weird errors on SBCL in some circumstances. Disabled for now.
  40 ;;         (declaim (inline ,(integer-reader-name bytes t)
  41 ;;                          ,(integer-reader-name bytes nil)))
  42          (declaim (ftype (function (t) (signed-byte ,bits))
  43                          ,(integer-reader-name bytes t)))
  44          ,(generate-reader t)
  45          (declaim (ftype (function (t) (unsigned-byte ,bits))
  46                          ,(integer-reader-name bytes nil)))
  47          ,(generate-reader nil)))))
  48
  49 (defmacro integer-writer (bytes)
  50   "Create a function to write integers to a binary stream."
  51   (let ((bits (* 8 bytes)))
  52     `(progn
  53       (declaim (inline ,(integer-writer-name bytes t)
  54                        ,(integer-writer-name bytes nil)))
  55       (defun ,(integer-writer-name bytes nil) (socket value)
  56         (declare (type stream socket)
  57                  (type (unsigned-byte ,bits) value)
  58                  #.*optimize*)
  59         ,@(if (= bytes 1)
  60               `((write-byte value socket))
  61               (loop :for byte :from (1- bytes) :downto 0
  62                     :collect `(write-byte (ldb (byte 8 ,(* byte 8)) value)
  63                                socket)))
  64         (values))
  65       (defun ,(integer-writer-name bytes t) (socket value)
  66         (declare (type stream socket)
  67                  (type (signed-byte ,bits) value)
  68                  #.*optimize*)
  69         ,@(if (= bytes 1)
  70               `((write-byte (ldb (byte 8 0) value) socket))
  71               (loop :for byte :from (1- bytes) :downto 0
  72                     :collect `(write-byte (ldb (byte 8 ,(* byte 8)) value)
  73                                socket)))
  74         (values)))))
  75
  76 ;; All the instances of the above that we need.
  77
  78 (integer-reader 1)
  79 (integer-reader 2)
  80 (integer-reader 4)
  81 (integer-reader 8)
  82
  83 (integer-writer 1)
  84 (integer-writer 2)
  85 (integer-writer 4)
  86
  87 (defun write-bytes (socket bytes)
  88   "Write a byte-array to a stream."
  89   (declare (type stream socket)
  90            (type (simple-array (unsigned-byte 8)) bytes)
  91            #.*optimize*)
  92   (write-sequence bytes socket))
  93
  94 (defun write-str (socket string)
  95   "Write a null-terminated string to a stream \(encoding it when UTF-8
  96 support is enabled.)."
  97   (declare (type stream socket)
  98            (type string string)
  99            #.*optimize*)
 100   (enc-write-string string socket)
 101   (write-uint1 socket 0))
 102
 103 (declaim (ftype (function (t unsigned-byte)
 104                           (simple-array (unsigned-byte 8) (*)))
 105                 read-bytes))
 106 (defun read-bytes (socket length)
 107   "Read a byte array of the given length from a stream."
 108   (declare (type stream socket)
 109            (type fixnum length)
 110            #.*optimize*)
 111   (let ((result (make-array length :element-type '(unsigned-byte 8))))
 112     (read-sequence result socket)
 113     result))
 114
 115 (declaim (ftype (function (t) string) read-str))
 116 (defun read-str (socket)
 117   "Read a null-terminated string from a stream. Takes care of encoding
 118 when UTF-8 support is enabled."
 119   (declare (type stream socket)
 120            #.*optimize*)
 121   (enc-read-string socket :null-terminated t))
 122
 123 (declaim (ftype (function (t) string) read-simple-str))
 124 (defun read-simple-str (socket)
 125   "Read a null-terminated string from a stream. Interprets it as ASCII."
 126   (declare (type stream socket)
 127            #.*optimize*)
 128   (with-output-to-string (out)
 129     (loop :for b := (read-byte socket nil 0) :do
 130        (cond ((eq b 0) (return))
 131              ((< b 128) (write-char (code-char b) out))))))
 132
 133 (defun skip-bytes (socket length)
 134   "Skip a given number of bytes in a binary stream."
 135   (declare (type stream socket)
 136            (type (unsigned-byte 32) length)
 137            #.*optimize*)
 138   (dotimes (i length)
 139     (read-byte socket)))
 140
 141 (defun skip-str (socket)
 142   "Skip a null-terminated string."
 143   (declare (type stream socket)
 144            #.*optimize*)
 145   (loop :for char :of-type fixnum = (read-byte socket)
 146         :until (zerop char)))
 147
 148 (defun ensure-socket-is-closed (socket &key abort)
 149   (when (open-stream-p socket)
 150     (handler-case
 151         (close socket :abort abort)
 152       (error (error)
 153         (warn "Ignoring the error which happened while trying to close PostgreSQL socket: ~A" error)))))