3rdparties/software/cffi_0.21.0/src/strings.lisp (13274 bytes)
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))