1 (in-package :cl-postgres
)
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
)))))
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)
20 `(if (logbitp ,(1- bits
) result
)
21 (dpb result
(byte ,(1- bits
) 0) -
1)
24 (generate-reader (signed)
25 `(defun ,(integer-reader-name bytes signed
) (socket)
26 (declare (type stream socket
)
29 `(let ((result (the (unsigned-byte 8) (read-byte socket
))))
30 (declare (type (unsigned-byte 8) result
))
31 ,(return-form signed
))
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
))))))
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
)))
45 (declaim (ftype (function (t) (unsigned-byte ,bits
))
46 ,(integer-reader-name bytes nil
)))
47 ,(generate-reader nil
)))))
49 (defmacro integer-writer
(bytes)
50 "Create a function to write integers to a binary stream."
51 (let ((bits (* 8 bytes
)))
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
)
60 `((write-byte value socket
))
61 (loop :for byte
:from
(1- bytes
) :downto
0
62 :collect
`(write-byte (ldb (byte 8 ,(* byte
8)) value
)
65 (defun ,(integer-writer-name bytes t
) (socket value
)
66 (declare (type stream socket
)
67 (type (signed-byte ,bits
) value
)
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
)
76 ;; All the instances of the above that we need.
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
)
92 (write-sequence bytes socket
))
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
)
100 (enc-write-string string socket
)
101 (write-uint1 socket
0))
103 (declaim (ftype (function (t unsigned-byte
)
104 (simple-array (unsigned-byte 8) (*)))
106 (defun read-bytes (socket length
)
107 "Read a byte array of the given length from a stream."
108 (declare (type stream socket
)
111 (let ((result (make-array length
:element-type
'(unsigned-byte 8))))
112 (read-sequence result socket
)
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
)
121 (enc-read-string socket
:null-terminated t
))
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
)
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
))))))
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
)
141 (defun skip-str (socket)
142 "Skip a null-terminated string."
143 (declare (type stream socket
)
145 (loop :for char
:of-type fixnum
= (read-byte socket
)
146 :until
(zerop char
)))
148 (defun ensure-socket-is-closed (socket &key abort
)
149 (when (open-stream-p socket
)
151 (close socket
:abort abort
)
153 (warn "Ignoring the error which happened while trying to close PostgreSQL socket: ~A" error
)))))