cl-postgres/communicate.lisp

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