Coverage report: /home/luis/src/cffi/src/strings.lisp

KindCoveredAll%
expression5556 98.2
branch34 75.0
Key
Not instrumented
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
 ;;;
7
 ;;; Permission is hereby granted, free of charge, to any person
8
 ;;; obtaining a copy of this software and associated documentation
9
 ;;; files (the "Software"), to deal in the Software without
10
 ;;; restriction, including without limitation the rights to use, copy,
11
 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
12
 ;;; of the Software, and to permit persons to whom the Software is
13
 ;;; furnished to do so, subject to the following conditions:
14
 ;;;
15
 ;;; The above copyright notice and this permission notice shall be
16
 ;;; included in all copies or substantial portions of the Software.
17
 ;;;
18
 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
19
 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
20
 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
21
 ;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
22
 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
23
 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
24
 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
25
 ;;; DEALINGS IN THE SOFTWARE.
26
 ;;;
27
 
28
 (in-package #:cffi)
29
 
30
 ;;; FIXME: we used to support ub8 arrays here. Look into that.
31
 
32
 ;;;# Foreign String Conversion
33
 ;;;
34
 ;;; Functions for converting NULL-terminated C-strings to Lisp strings
35
 ;;; and vice versa.  The string functions accept an ENCODING keyword
36
 ;;; argument which is used to specify the encoding to use when
37
 ;;; converting to/from foreign strings.
38
 ;;;
39
 ;;; Currently, encodings are really only supported on Unicode Lisps,
40
 ;;; to avoid encumbering CFFI with lots of character conversion tables
41
 ;;; and such.  On Lisps with 8-bit characters, Lisp characters will be
42
 ;;; converted into bytes without conversion.
43
 
44
 (defun lisp-string-to-foreign (string buffer bufsize
45
                                &key (encoding (default-encoding)))
46
   "Copy characters from a Lisp STRING as bytes encoded with
47
 ENCODING into BUFFER of BUFSIZE bytes.  The resulting string will
48
 always be null-terminated, but may be truncated if the octet
49
 representation and null terminator are larger than BUFSIZE."
50
   (%lisp-string-into-foreign string encoding buffer bufsize))
51
 
52
 (defun foreign-string-to-lisp (pointer &key (offset 0) count
53
                                (encoding (default-encoding)))
54
   "Copy at most COUNT bytes from POINTER plus OFFSET encoded in
55
 ENCODING into a Lisp string and return it.  If POINTER is a null
56
 pointer, this returns nil."
57
   (unless (null-pointer-p pointer)
58
     (%foreign-string-to-lisp pointer encoding :offset offset
59
                              :count count)))
60
 
61
 ;;;# Using Foreign Strings
62
 
63
 (defun foreign-string-alloc (string &key (encoding (default-encoding))
64
                              (start 0) end)
65
   "Allocate a foreign string containing Lisp string STRING.
66
 The string must be freed with FOREIGN-STRING-FREE."
67
   (%lisp-string-to-foreign string encoding :start start :end end))
68
 
69
 ;;; Too lazy to write a %foreign-string-free in all backends, so this
70
 ;;; ackward thing is here to remind me that a definterface and
71
 ;;; defimplementation kind of thing (like what SLIME has) would be
72
 ;;; nice to have.
73
 #-#.(cl:if (cl:find-symbol (cl:symbol-name '#:foreign-string-free) '#:cffi-sys)
74
            '(:and) '(:or))
75
 (defun foreign-string-free (ptr)
76
   "Free a foreign string allocated by FOREIGN-STRING-ALLOC."
77
   (foreign-free ptr))
78
 
79
 (defmacro with-foreign-string ((var lisp-string &rest args) &body body)
80
   "Bind VAR to a foreign string containing LISP-STRING in BODY."
81
   `(let ((,var (foreign-string-alloc ,lisp-string ,@args)))
82
      (unwind-protect
83
           (progn ,@body)
84
        (foreign-string-free ,var))))
85
 
86
 (defmacro with-foreign-pointer-as-string
87
     ((var size &optional size-var) &body body)
88
   "Like WITH-FOREIGN-POINTER except VAR as a Lisp string is used as
89
 the return value of an implicit PROGN around BODY."
90
   `(with-foreign-pointer (,var ,size ,size-var)
91
      (progn
92
        ,@body
93
        (foreign-string-to-lisp ,var))))
94
 
95
 ;;;# Automatic Conversion of Foreign Strings
96
 
97
 (define-foreign-type foreign-string-type ()
98
   (;; CFFI encoding of this string.
99
    (encoding :initform (default-encoding) :initarg :encoding :reader encoding))
100
   (:actual-type :pointer))
101
 
102
 (define-parse-method :string (&key (encoding (default-encoding)))
103
   (make-instance 'foreign-string-type :encoding encoding))
104
 
105
 ;;; Display the encoding when printing a FOREIGN-STRING-TYPE instance.
106
 (defmethod print-object ((type foreign-string-type) stream)
107
   (print-unreadable-object (type stream :type t)
108
     (format stream "~S" (encoding type))))
109
 
110
 (defmethod translate-to-foreign ((s string) (type foreign-string-type))
111
   (values (foreign-string-alloc s :encoding (encoding type)) t))
112
 
113
 (defmethod translate-to-foreign (obj (type foreign-string-type))
114
   (cond
115
     ((pointerp obj)
116
      (values obj nil))
117
     ;; ((typep obj '(array (unsigned-byte 8)))
118
     ;;  (values (foreign-string-alloc obj) t))
119
     (t (error "~A is not a Lisp string, (array (unsigned-byte 8)) or pointer."
120
               obj))))
121
 
122
 (defmethod translate-from-foreign (ptr (type foreign-string-type))
123
   (foreign-string-to-lisp ptr :encoding (encoding type)))
124
 
125
 (defmethod free-translated-object (ptr (type foreign-string-type) free-p)
126
   (when free-p
127
     (foreign-string-free ptr)))
128
 
129
 ;;; STRING+PTR
130
 
131
 (define-foreign-type foreign-string+ptr-type (foreign-string-type)
132
   ())
133
 
134
 (define-parse-method :string+ptr (&key (encoding (default-encoding)))
135
   (make-instance 'foreign-string+ptr-type :encoding encoding))
136
 
137
 (defmethod translate-from-foreign (value (type foreign-string+ptr-type))
138
   (list (foreign-string-to-lisp value) value))
139