Coverage report: /home/ellis/.stash/quicklisp/dists/quicklisp/software/cffi-20250622-git/src/strings.lisp

KindCoveredAll%
expression76273 27.8
branch16 16.7
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
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
       (unwind-protect-case ()
196
           (funcall (encoder mapping) string start end ptr 0)
197
         (:abort (foreign-free ptr)))
198
       (dotimes (i nul-length)
199
         (setf (mem-ref ptr :char (+ count i)) 0))
200
       (values ptr length))))
201
 
202
 (defun foreign-string-free (ptr)
203
   "Free a foreign string allocated by FOREIGN-STRING-ALLOC."
204
   (foreign-free ptr))
205
 
206
 (defmacro with-foreign-string ((var-or-vars lisp-string &rest args) &body body)
207
   "VAR-OR-VARS is not evaluated and should be a list of the form
208
 \(VAR &OPTIONAL BYTE-SIZE-VAR) or just a VAR symbol.  VAR is
209
 bound to a foreign string containing LISP-STRING in BODY.  When
210
 BYTE-SIZE-VAR is specified then bind the C buffer size
211
 \(including the possible null terminator\(s)) to this variable."
212
   (destructuring-bind (var &optional size-var)
213
       (ensure-list var-or-vars)
214
     `(multiple-value-bind (,var ,@(when size-var (list size-var)))
215
          (foreign-string-alloc ,lisp-string ,@args)
216
        (unwind-protect
217
             (progn ,@body)
218
          (foreign-string-free ,var)))))
219
 
220
 (defmacro with-foreign-strings (bindings &body body)
221
   "See WITH-FOREIGN-STRING's documentation."
222
   (if bindings
223
       `(with-foreign-string ,(first bindings)
224
          (with-foreign-strings ,(rest bindings)
225
            ,@body))
226
       `(progn ,@body)))
227
 
228
 (defmacro with-foreign-pointer-as-string
229
     ((var-or-vars size &rest args) &body body)
230
   "VAR-OR-VARS is not evaluated and should be a list of the form
231
 \(VAR &OPTIONAL SIZE-VAR) or just a VAR symbol.  VAR is bound to
232
 a foreign buffer of size SIZE within BODY.  The return value is
233
 constructed by calling FOREIGN-STRING-TO-LISP on the foreign
234
 buffer along with ARGS." ; fix wording, sigh
235
   (destructuring-bind (var &optional size-var)
236
       (ensure-list var-or-vars)
237
     `(with-foreign-pointer (,var ,size ,size-var)
238
        (progn
239
          ,@body
240
          (values (foreign-string-to-lisp ,var ,@args))))))
241
 
242
 ;;;# Automatic Conversion of Foreign Strings
243
 
244
 (define-foreign-type foreign-string-type ()
245
   (;; CFFI encoding of this string.
246
    (encoding :initform nil :initarg :encoding :reader encoding)
247
    ;; Should we free after translating from foreign?
248
    (free-from-foreign :initarg :free-from-foreign
249
                       :reader fst-free-from-foreign-p
250
                       :initform nil :type boolean)
251
    ;; Should we free after translating to foreign?
252
    (free-to-foreign :initarg :free-to-foreign
253
                     :reader fst-free-to-foreign-p
254
                     :initform t :type boolean))
255
   (:actual-type :pointer)
256
   (:simple-parser :string))
257
 
258
 ;;; describe me
259
 (defun fst-encoding (type)
260
   (or (encoding type) *default-foreign-encoding*))
261
 
262
 ;;; Display the encoding when printing a FOREIGN-STRING-TYPE instance.
263
 (defmethod print-object ((type foreign-string-type) stream)
264
   (print-unreadable-object (type stream :type t)
265
     (format stream "~S" (fst-encoding type))))
266
 
267
 (defmethod translate-to-foreign ((s string) (type foreign-string-type))
268
   (values (foreign-string-alloc s :encoding (fst-encoding type))
269
           (fst-free-to-foreign-p type)))
270
 
271
 (defmethod translate-to-foreign (obj (type foreign-string-type))
272
   (cond
273
     ((pointerp obj)
274
      (values obj nil))
275
     ;; FIXME: we used to support UB8 vectors but not anymore.
276
     ;; ((typep obj '(array (unsigned-byte 8)))
277
     ;;  (values (foreign-string-alloc obj) t))
278
     (t (error "~A is not a Lisp string or pointer." obj))))
279
 
280
 (defmethod translate-from-foreign (ptr (type foreign-string-type))
281
   (unwind-protect
282
        (values (foreign-string-to-lisp ptr :encoding (fst-encoding type)))
283
     (when (fst-free-from-foreign-p type)
284
       (foreign-free ptr))))
285
 
286
 (defmethod free-translated-object (ptr (type foreign-string-type) free-p)
287
   (when free-p
288
     (foreign-string-free ptr)))
289
 
290
 (defmethod expand-to-foreign-dyn-indirect
291
     (value var body (type foreign-string-type))
292
   (alexandria:with-gensyms (str)
293
     (expand-to-foreign-dyn
294
      value
295
      str
296
      (list 
297
       (expand-to-foreign-dyn-indirect str var body (parse-type :pointer)))
298
      type)))
299
 
300
 ;;;# STRING+PTR
301
 
302
 (define-foreign-type foreign-string+ptr-type (foreign-string-type)
303
   ()
304
   (:simple-parser :string+ptr))
305
 
306
 (defmethod translate-from-foreign (value (type foreign-string+ptr-type))
307
   (list (call-next-method) value))