src/strings.lisp

   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))