CodeMirror: Common Lisp mode

(in-package :cl-postgres)

;; These are used to synthesize reader and writer names for integer
;; reading/writing functions when the amount of bytes and the
;; signedness is known. Both the macro that creates the functions and
;; some macros that use them create names this way.
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun integer-reader-name (bytes signed)
    (intern (with-standard-io-syntax
              (format nil "~a~a~a~a" '#:read- (if signed "" '#:u) '#:int bytes))))
  (defun integer-writer-name (bytes signed)
    (intern (with-standard-io-syntax
              (format nil "~a~a~a~a" '#:write- (if signed "" '#:u) '#:int bytes)))))

(defmacro integer-reader (bytes)
  "Create a function to read integers from a binary stream."
  (let ((bits (* bytes 8)))
    (labels ((return-form (signed)
               (if signed
                   `(if (logbitp ,(1- bits) result)
                        (dpb result (byte ,(1- bits) 0) -1)
                        result)
                   `result))
             (generate-reader (signed)
               `(defun ,(integer-reader-name bytes signed) (socket)
                  (declare (type stream socket)
                           #.*optimize*)
                  ,(if (= bytes 1)
                       `(let ((result (the (unsigned-byte 8) (read-byte socket))))
                          (declare (type (unsigned-byte 8) result))
                          ,(return-form signed))
                       `(let ((result 0))
                          (declare (type (unsigned-byte ,bits) result))
                          ,@(loop :for byte :from (1- bytes) :downto 0
                                   :collect `(setf (ldb (byte 8 ,(* 8 byte)) result)
                                                   (the (unsigned-byte 8) (read-byte socket))))
                          ,(return-form signed))))))
      `(progn
;; This causes weird errors on SBCL in some circumstances. Disabled for now.
;;         (declaim (inline ,(integer-reader-name bytes t)
;;                          ,(integer-reader-name bytes nil)))
         (declaim (ftype (function (t) (signed-byte ,bits))
                         ,(integer-reader-name bytes t)))
         ,(generate-reader t)
         (declaim (ftype (function (t) (unsigned-byte ,bits))
                         ,(integer-reader-name bytes nil)))
         ,(generate-reader nil)))))

(defmacro integer-writer (bytes)
  "Create a function to write integers to a binary stream."
  (let ((bits (* 8 bytes)))
    `(progn
      (declaim (inline ,(integer-writer-name bytes t)
                       ,(integer-writer-name bytes nil)))
      (defun ,(integer-writer-name bytes nil) (socket value)
        (declare (type stream socket)
                 (type (unsigned-byte ,bits) value)
                 #.*optimize*)
        ,@(if (= bytes 1)
              `((write-byte value socket))
              (loop :for byte :from (1- bytes) :downto 0
                    :collect `(write-byte (ldb (byte 8 ,(* byte 8)) value)
                               socket)))
        (values))
      (defun ,(integer-writer-name bytes t) (socket value)
        (declare (type stream socket)
                 (type (signed-byte ,bits) value)
                 #.*optimize*)
        ,@(if (= bytes 1)
              `((write-byte (ldb (byte 8 0) value) socket))
              (loop :for byte :from (1- bytes) :downto 0
                    :collect `(write-byte (ldb (byte 8 ,(* byte 8)) value)
                               socket)))
        (values)))))

;; All the instances of the above that we need.

(integer-reader 1)
(integer-reader 2)
(integer-reader 4)
(integer-reader 8)

(integer-writer 1)
(integer-writer 2)
(integer-writer 4)

(defun write-bytes (socket bytes)
  "Write a byte-array to a stream."
  (declare (type stream socket)
           (type (simple-array (unsigned-byte 8)) bytes)
           #.*optimize*)
  (write-sequence bytes socket))

(defun write-str (socket string)
  "Write a null-terminated string to a stream \(encoding it when UTF-8
support is enabled.)."
  (declare (type stream socket)
           (type string string)
           #.*optimize*)
  (enc-write-string string socket)
  (write-uint1 socket 0))

(declaim (ftype (function (t unsigned-byte)
                          (simple-array (unsigned-byte 8) (*)))
                read-bytes))
(defun read-bytes (socket length)
  "Read a byte array of the given length from a stream."
  (declare (type stream socket)
           (type fixnum length)
           #.*optimize*)
  (let ((result (make-array length :element-type '(unsigned-byte 8))))
    (read-sequence result socket)
    result))

(declaim (ftype (function (t) string) read-str))
(defun read-str (socket)
  "Read a null-terminated string from a stream. Takes care of encoding
when UTF-8 support is enabled."
  (declare (type stream socket)
           #.*optimize*)
  (enc-read-string socket :null-terminated t))

(defun skip-bytes (socket length)
  "Skip a given number of bytes in a binary stream."
  (declare (type stream socket)
           (type (unsigned-byte 32) length)
           #.*optimize*)
  (dotimes (i length)
    (read-byte socket)))

(defun skip-str (socket)
  "Skip a null-terminated string."
  (declare (type stream socket)
           #.*optimize*)
  (loop :for char :of-type fixnum = (read-byte socket)
        :until (zerop char)))

(defun ensure-socket-is-closed (socket &key abort)
  (when (open-stream-p socket)
    (handler-case
        (close socket :abort abort)
      (error (error)
        (warn "Ignoring the error which happened while trying to close PostgreSQL socket: ~A" error)))))

MIME types defined: text/x-common-lisp.