strings.lisp - clic - Clic is an command line interactive client for gopher wri… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
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 <[email protected]> | |
6 ;;; Copyright (C) 2005-2007, Luis Oliveira <[email protected]> | |
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 … | |
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) ,va… | |
96 (mem-ref ,ptr :uint8 (+ 2 ,off)) (ldb (byte 8 8) ,va… | |
97 (mem-ref ,ptr :uint8 (1+ ,off)) (ldb (byte 8 16) ,va… | |
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) ,v… | |
105 (mem-ref ,ptr :uint8 (+ ,off 3)) (ldb (byte 8 24) ,v… | |
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 … | |
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-str… | |
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 n… | |
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-en… | |
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-cha… | |
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-enco… | |
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-str… | |
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) &bod… | |
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)) |