Common Lisp mode

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
(defun skip-bytes (socket length)
124
  "Skip a given number of bytes in a binary stream."
125
  (declare (type stream socket)
126
           (type (unsigned-byte 32) length)
127
           #.*optimize*)
128
  (dotimes (i length)
129
    (read-byte socket)))
130
 
131
(defun skip-str (socket)
132
  "Skip a null-terminated string."
133
  (declare (type stream socket)
134
           #.*optimize*)
135
  (loop :for char :of-type fixnum = (read-byte socket)
136
        :until (zerop char)))
137
 
138
(defun ensure-socket-is-closed (socket &key abort)
139
  (when (open-stream-p socket)
140
    (handler-case
141
        (close socket :abort abort)
142
      (error (error)
143
        (warn "Ignoring the error which happened while trying to close PostgreSQL socket: ~A" error)))))
144
 
 

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