strings.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
strings.lisp (13274B)
---
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; strings.lisp --- Operations on foreign strings.
4 ;;;
5 ;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
6 ;;; Copyright (C) 2005-2007, Luis Oliveira <loliveira@common-lisp.net>
7 ;;;
8 ;;; Permission is hereby granted, free of charge, to any person
9 ;;; obtaining a copy of this software and associated documentation
10 ;;; files (the "Software"), to deal in the Software without
11 ;;; restriction, including without limitation the rights to use, copy,
12 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
13 ;;; of the Software, and to permit persons to whom the Software is
14 ;;; furnished to do so, subject to the following conditions:
15 ;;;
16 ;;; The above copyright notice and this permission notice shall be
17 ;;; included in all copies or substantial portions of the Software.
18 ;;;
19 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
20 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
21 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
22 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
23 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
24 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
25 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
26 ;;; DEALINGS IN THE SOFTWARE.
27 ;;;
28
29 (in-package #:cffi)
30
31 ;;;# Foreign String Conversion
32 ;;;
33 ;;; Functions for converting NULL-terminated C-strings to Lisp strings
34 ;;; and vice versa. The string functions accept an ENCODING keyword
35 ;;; argument which is used to specify the encoding to use when
36 ;;; converting to/from foreign strings.
37
38 (defvar *default-foreign-encoding* :utf-8
39 "Default foreign encoding.")
40
41 ;;; TODO: refactor, sigh. Also, this should probably be a function.
42 (defmacro bget (ptr off &optional (bytes 1) (endianness :ne))
43 (let ((big-endian (member endianness
44 '(:be #+big-endian :ne #+little-endian :re))))
45 (once-only (ptr off)
46 (ecase bytes
47 (1 `(mem-ref ,ptr :uint8 ,off))
48 (2 (if big-endian
49 #+big-endian
50 `(mem-ref ,ptr :uint16 ,off)
51 #-big-endian
52 `(dpb (mem-ref ,ptr :uint8 ,off) (byte 8 8)
53 (mem-ref ,ptr :uint8 (1+ ,off)))
54 #+little-endian
55 `(mem-ref ,ptr :uint16 ,off)
56 #-little-endian
57 `(dpb (mem-ref ,ptr :uint8 (1+ ,off)) (byte 8 8)
58 (mem-ref ,ptr :uint8 ,off))))
59 (4 (if big-endian
60 #+big-endian
61 `(mem-ref ,ptr :uint32 ,off)
62 #-big-endian
63 `(dpb (mem-ref ,ptr :uint8 ,off) (byte 8 24)
64 (dpb (mem-ref ,ptr :uint8 (1+ ,off)) (byte 8 16)
65 (dpb (mem-ref ,ptr :uint8 (+ ,off 2)) (byte 8 8)
66 (mem-ref ,ptr :uint8 (+ ,off 3)))))
67 #+little-endian
68 `(mem-ref ,ptr :uint32 ,off)
69 #-little-endian
70 `(dpb (mem-ref ,ptr :uint8 (+ ,off 3)) (byte 8 24)
71 (dpb (mem-ref ,ptr :uint8 (+ ,off 2)) (byte 8 16)
72 (dpb (mem-ref ,ptr :uint8 (1+ ,off)) (byte 8 8)
73 (mem-ref ,ptr :uint8 ,off))))))))))
74
75 (defmacro bset (val ptr off &optional (bytes 1) (endianness :ne))
76 (let ((big-endian (member endianness
77 '(:be #+big-endian :ne #+little-endian :re))))
78 (ecase bytes
79 (1 `(setf (mem-ref ,ptr :uint8 ,off) ,val))
80 (2 (if big-endian
81 #+big-endian
82 `(setf (mem-ref ,ptr :uint16 ,off) ,val)
83 #-big-endian
84 `(setf (mem-ref ,ptr :uint8 (1+ ,off)) (ldb (byte 8 0) ,val)
85 (mem-ref ,ptr :uint8 ,off) (ldb (byte 8 8) ,val))
86 #+little-endian
87 `(setf (mem-ref ,ptr :uint16 ,off) ,val)
88 #-little-endian
89 `(setf (mem-ref ,ptr :uint8 ,off) (ldb (byte 8 0) ,val)
90 (mem-ref ,ptr :uint8 (1+ ,off)) (ldb (byte 8 8) ,val))))
91 (4 (if big-endian
92 #+big-endian
93 `(setf (mem-ref ,ptr :uint32 ,off) ,val)
94 #-big-endian
95 `(setf (mem-ref ,ptr :uint8 (+ 3 ,off)) (ldb (byte 8 0) ,val)
96 (mem-ref ,ptr :uint8 (+ 2 ,off)) (ldb (byte 8 8) ,val)
97 (mem-ref ,ptr :uint8 (1+ ,off)) (ldb (byte 8 16) ,val)
98 (mem-ref ,ptr :uint8 ,off) (ldb (byte 8 24) ,val))
99 #+little-endian
100 `(setf (mem-ref ,ptr :uint32 ,off) ,val)
101 #-little-endian
102 `(setf (mem-ref ,ptr :uint8 ,off) (ldb (byte 8 0) ,val)
103 (mem-ref ,ptr :uint8 (1+ ,off)) (ldb (byte 8 8) ,val)
104 (mem-ref ,ptr :uint8 (+ ,off 2)) (ldb (byte 8 16) ,val)
105 (mem-ref ,ptr :uint8 (+ ,off 3)) (ldb (byte 8 24) ,val)))))))
106
107 ;;; TODO: tackle optimization notes.
108 (defparameter *foreign-string-mappings*
109 (instantiate-concrete-mappings
110 ;; :optimize ((speed 3) (debug 0) (compilation-speed 0) (safety 0))
111 :octet-seq-getter bget
112 :octet-seq-setter bset
113 :octet-seq-type foreign-pointer
114 :code-point-seq-getter babel::string-get
115 :code-point-seq-setter babel::string-set
116 :code-point-seq-type babel:simple-unicode-string))
117
118 (defun null-terminator-len (encoding)
119 (length (enc-nul-encoding (get-character-encoding encoding))))
120
121 (defun lisp-string-to-foreign (string buffer bufsize &key (start 0) end offset
122 (encoding *default-foreign-encoding*))
123 (check-type string string)
124 (when offset
125 (setq buffer (inc-pointer buffer offset)))
126 (with-checked-simple-vector ((string (coerce string 'babel:unicode-string))
127 (start start) (end end))
128 (declare (type simple-string string))
129 (let ((mapping (lookup-mapping *foreign-string-mappings* encoding))
130 (nul-len (null-terminator-len encoding)))
131 (assert (plusp bufsize))
132 (multiple-value-bind (size end)
133 (funcall (octet-counter mapping) string start end (- bufsize nul-len))
134 (funcall (encoder mapping) string start end buffer 0)
135 (dotimes (i nul-len)
136 (setf (mem-ref buffer :char (+ size i)) 0))))
137 buffer))
138
139 ;;; Expands into a loop that calculates the length of the foreign
140 ;;; string at PTR plus OFFSET, using ACCESSOR and looking for a null
141 ;;; terminator of LENGTH bytes.
142 (defmacro %foreign-string-length (ptr offset type length)
143 (once-only (ptr offset)
144 `(do ((i 0 (+ i ,length)))
145 ((zerop (mem-ref ,ptr ,type (+ ,offset i))) i)
146 (declare (fixnum i)))))
147
148 ;;; Return the length in octets of the null terminated foreign string
149 ;;; at POINTER plus OFFSET octets, assumed to be encoded in ENCODING,
150 ;;; a CFFI encoding. This should be smart enough to look for 8-bit vs
151 ;;; 16-bit null terminators, as appropriate for the encoding.
152 (defun foreign-string-length (pointer &key (encoding *default-foreign-encoding*)
153 (offset 0))
154 (ecase (null-terminator-len encoding)
155 (1 (%foreign-string-length pointer offset :uint8 1))
156 (2 (%foreign-string-length pointer offset :uint16 2))
157 (4 (%foreign-string-length pointer offset :uint32 4))))
158
159 (defun foreign-string-to-lisp (pointer &key (offset 0) count
160 (max-chars (1- array-total-size-limit))
161 (encoding *default-foreign-encoding*))
162 "Copy at most COUNT bytes from POINTER plus OFFSET encoded in
163 ENCODING into a Lisp string and return it. If POINTER is a null
164 pointer, NIL is returned."
165 (unless (null-pointer-p pointer)
166 (let ((count (or count
167 (foreign-string-length
168 pointer :encoding encoding :offset offset)))
169 (mapping (lookup-mapping *foreign-string-mappings* encoding)))
170 (assert (plusp max-chars))
171 (multiple-value-bind (size new-end)
172 (funcall (code-point-counter mapping)
173 pointer offset (+ offset count) max-chars)
174 (let ((string (make-string size :element-type 'babel:unicode-char)))
175 (funcall (decoder mapping) pointer offset new-end string 0)
176 (values string (- new-end offset)))))))
177
178 ;;;# Using Foreign Strings
179
180 (defun foreign-string-alloc (string &key (encoding *default-foreign-encoding*)
181 (null-terminated-p t) (start 0) end)
182 "Allocate a foreign string containing Lisp string STRING.
183 The string must be freed with FOREIGN-STRING-FREE."
184 (check-type string string)
185 (with-checked-simple-vector ((string (coerce string 'babel:unicode-string))
186 (start start) (end end))
187 (declare (type simple-string string))
188 (let* ((mapping (lookup-mapping *foreign-string-mappings* encoding))
189 (count (funcall (octet-counter mapping) string start end 0))
190 (nul-length (if null-terminated-p
191 (null-terminator-len encoding)
192 0))
193 (length (+ count nul-length))
194 (ptr (foreign-alloc :char :count length)))
195 (funcall (encoder mapping) string start end ptr 0)
196 (dotimes (i nul-length)
197 (setf (mem-ref ptr :char (+ count i)) 0))
198 (values ptr length))))
199
200 (defun foreign-string-free (ptr)
201 "Free a foreign string allocated by FOREIGN-STRING-ALLOC."
202 (foreign-free ptr))
203
204 (defmacro with-foreign-string ((var-or-vars lisp-string &rest args) &body body)
205 "VAR-OR-VARS is not evaluated and should be a list of the form
206 \(VAR &OPTIONAL BYTE-SIZE-VAR) or just a VAR symbol. VAR is
207 bound to a foreign string containing LISP-STRING in BODY. When
208 BYTE-SIZE-VAR is specified then bind the C buffer size
209 \(including the possible null terminator\(s)) to this variable."
210 (destructuring-bind (var &optional size-var)
211 (ensure-list var-or-vars)
212 `(multiple-value-bind (,var ,@(when size-var (list size-var)))
213 (foreign-string-alloc ,lisp-string ,@args)
214 (unwind-protect
215 (progn ,@body)
216 (foreign-string-free ,var)))))
217
218 (defmacro with-foreign-strings (bindings &body body)
219 "See WITH-FOREIGN-STRING's documentation."
220 (if bindings
221 `(with-foreign-string ,(first bindings)
222 (with-foreign-strings ,(rest bindings)
223 ,@body))
224 `(progn ,@body)))
225
226 (defmacro with-foreign-pointer-as-string
227 ((var-or-vars size &rest args) &body body)
228 "VAR-OR-VARS is not evaluated and should be a list of the form
229 \(VAR &OPTIONAL SIZE-VAR) or just a VAR symbol. VAR is bound to
230 a foreign buffer of size SIZE within BODY. The return value is
231 constructed by calling FOREIGN-STRING-TO-LISP on the foreign
232 buffer along with ARGS." ; fix wording, sigh
233 (destructuring-bind (var &optional size-var)
234 (ensure-list var-or-vars)
235 `(with-foreign-pointer (,var ,size ,size-var)
236 (progn
237 ,@body
238 (values (foreign-string-to-lisp ,var ,@args))))))
239
240 ;;;# Automatic Conversion of Foreign Strings
241
242 (define-foreign-type foreign-string-type ()
243 (;; CFFI encoding of this string.
244 (encoding :initform nil :initarg :encoding :reader encoding)
245 ;; Should we free after translating from foreign?
246 (free-from-foreign :initarg :free-from-foreign
247 :reader fst-free-from-foreign-p
248 :initform nil :type boolean)
249 ;; Should we free after translating to foreign?
250 (free-to-foreign :initarg :free-to-foreign
251 :reader fst-free-to-foreign-p
252 :initform t :type boolean))
253 (:actual-type :pointer)
254 (:simple-parser :string))
255
256 ;;; describe me
257 (defun fst-encoding (type)
258 (or (encoding type) *default-foreign-encoding*))
259
260 ;;; Display the encoding when printing a FOREIGN-STRING-TYPE instance.
261 (defmethod print-object ((type foreign-string-type) stream)
262 (print-unreadable-object (type stream :type t)
263 (format stream "~S" (fst-encoding type))))
264
265 (defmethod translate-to-foreign ((s string) (type foreign-string-type))
266 (values (foreign-string-alloc s :encoding (fst-encoding type))
267 (fst-free-to-foreign-p type)))
268
269 (defmethod translate-to-foreign (obj (type foreign-string-type))
270 (cond
271 ((pointerp obj)
272 (values obj nil))
273 ;; FIXME: we used to support UB8 vectors but not anymore.
274 ;; ((typep obj '(array (unsigned-byte 8)))
275 ;; (values (foreign-string-alloc obj) t))
276 (t (error "~A is not a Lisp string or pointer." obj))))
277
278 (defmethod translate-from-foreign (ptr (type foreign-string-type))
279 (unwind-protect
280 (values (foreign-string-to-lisp ptr :encoding (fst-encoding type)))
281 (when (fst-free-from-foreign-p type)
282 (foreign-free ptr))))
283
284 (defmethod free-translated-object (ptr (type foreign-string-type) free-p)
285 (when free-p
286 (foreign-string-free ptr)))
287
288 (defmethod expand-to-foreign-dyn-indirect
289 (value var body (type foreign-string-type))
290 (alexandria:with-gensyms (str)
291 (expand-to-foreign-dyn
292 value
293 str
294 (list
295 (expand-to-foreign-dyn-indirect str var body (parse-type :pointer)))
296 type)))
297
298 ;;;# STRING+PTR
299
300 (define-foreign-type foreign-string+ptr-type (foreign-string-type)
301 ()
302 (:simple-parser :string+ptr))
303
304 (defmethod translate-from-foreign (value (type foreign-string+ptr-type))
305 (list (call-next-method) value))