GopherProxy

	tstrings.lisp - clic - Clic is an command line interactive client for gopher wr…
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	tstrings.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))