1 ;;;; CHAR-CODE -- Conversions between characters and byte
2 ;;;; representations thereof
5 (:use :cl #+sbcl :sb-gray #-sbcl :gray)
6 (:export "MAKE-ENCODER" "MAKE-DECODER" "ENCODE-STRING" "DECODE-STRING" "SYSTEM-CHARSET"
7 "NO-CODEC-ERROR" "CODING-ERROR"
8 "MAKE-CODEC-CHARACTER-STREAM"
9 "ASCII" "LATIN-1" "LATIN1" "UTF-8" "UTF8"))
10 (in-package :charcode)
14 (define-condition no-codec-error (error)
15 ((codec-name :initarg :codec-name))
16 (:report (lambda (c s)
17 (with-slots (codec-name) c
18 (format s "Could find no codec named ~A." codec-name)))))
20 (define-condition coding-error (error)
21 ((input :initarg :input)
22 (position :initarg :position)
23 (result :initarg :result)))
25 (define-condition simple-coding-error (coding-error simple-error) ())
27 (defun coding-error (input position result format &rest format-args)
28 (error 'simple-coding-error
29 :input input :position position :result result
30 :format-control format :format-arguments format-args))
32 (deftype decoder-fun () `(function ((array (unsigned-byte 8))
34 &key (start fixnum) (end fixnum))
36 (deftype encoder-fun () `(function ((array character)
37 (array (unsigned-byte 8))
38 &key (start fixnum) (end fixnum))
41 (defmacro define-encoder ((name) &body make-encoder)
42 `(setf (get ',name 'make-encoder) #'(lambda () ,@make-encoder)))
44 (defmacro define-decoder ((name) &body make-decoder)
45 `(setf (get ',name 'make-decoder) #'(lambda () ,@make-decoder)))
47 (defmacro define-codec-synonyms (name &rest synonyms)
48 `(eval-when (:load-toplevel :execute)
49 ,@(mapcar #'(lambda (sym)
50 `(setf (get ',sym 'make-encoder) (get ',name 'make-encoder)
51 (get ',sym 'make-decoder) (get ',name 'make-decoder)))
54 (defun make-encoder (name)
55 (the encoder-fun (values (funcall (or (get name 'make-encoder)
56 (error 'no-codec-error :codec-name name))))))
58 (defun make-decoder (name)
59 (the decoder-fun (values (funcall (or (get name 'make-decoder)
60 (error 'no-codec-error :codec-name name))))))
62 (defun system-charset ()
63 ;; XXX: Replace me with something perhaps more sensible.
66 (defun encode-string (string &optional (coding (system-charset)))
67 (declare (type string string))
68 (let ((encoder (make-encoder coding))
69 (buf (make-array (list (length string)) :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0)))
70 (unless (funcall encoder string buf)
71 (coding-error string (length string) buf "Encoding of string in ~A ended prematurely." coding))
74 (defun decode-string (buffer &optional (coding (system-charset)))
75 (declare (type (array (unsigned-byte 8)) buffer))
76 (let ((decoder (make-decoder coding))
77 (buf (make-array (list (length buffer)) :element-type 'character :adjustable t :fill-pointer 0)))
78 (unless (funcall decoder buffer buf)
79 (coding-error buffer (length buffer) buf "~A byte sequence ended prematurely." coding))
82 ;;; Gray stream implementation
84 (defclass codec-character-stream (fundamental-character-input-stream fundamental-character-output-stream)
85 ((decoder :initarg :decoder)
86 (encoder :initarg :encoder)
88 (read-pos :initform 0)
89 (buffer :initform (make-array '(64) :element-type 'character :adjustable t :fill-pointer 0))))
91 (defun make-codec-character-stream (real-stream &optional (charset (system-charset)))
92 (declare (type stream real-stream))
93 (make-instance 'codec-character-stream :decoder (make-decoder charset) :encoder (make-encoder charset) :back real-stream))
95 (defmethod close ((stream codec-character-stream) &key abort)
96 (with-slots (back) stream
97 (close back :abort abort))
100 (defmethod open-stream-p ((stream codec-character-stream))
101 (with-slots (back) stream
102 (open-stream-p stream)))
104 (defun ccs-ensure-buffer (stream len)
105 (declare (type codec-character-stream stream)
107 (with-slots (decoder back buffer read-pos) stream
108 (let ((readbuf (make-array (list len) :element-type '(unsigned-byte 8))))
109 (loop (unless (< (- (length buffer) read-pos) len) (return t))
110 (let ((readlen (read-sequence readbuf back :end (- len (- (length buffer) read-pos)))))
112 (return-from ccs-ensure-buffer nil))
113 (funcall decoder readbuf buffer :end readlen))))))
115 (defun ccs-clear-buffer (stream)
116 (declare (type codec-character-stream stream))
117 (with-slots (read-pos buffer) stream
118 (replace buffer buffer :start2 read-pos)
119 (setf (fill-pointer buffer) (- (fill-pointer buffer) read-pos)
122 (defmethod stream-read-char ((stream codec-character-stream))
123 (unless (ccs-ensure-buffer stream 1)
124 (return-from stream-read-char :eof))
125 (with-slots (read-pos buffer) stream
126 (prog1 (aref buffer read-pos)
127 (when (>= (incf read-pos) 16)
128 (ccs-clear-buffer stream)))))
130 (defmethod stream-unread-char ((stream codec-character-stream) char)
131 (with-slots (read-pos buffer) stream
133 (let ((len (length buffer)))
134 (when (< (array-dimension buffer 0) (+ len 16))
135 (adjust-array buffer (list (setf (fill-pointer buffer)
137 (replace buffer buffer :start1 16 :end2 len)))
138 (setf (aref buffer (decf read-pos)) char)
141 (defun ccs-wont-hang-p (stream)
142 (declare (type codec-character-stream stream))
143 (with-slots (read-pos back buffer) stream
144 (or (and (< read-pos (length buffer)) (aref buffer read-pos))
147 (defmethod stream-read-char-no-hang ((stream codec-character-stream))
148 (if (ccs-wont-hang-p stream)
149 (stream-read-char stream)
152 (defmethod stream-peek-char ((stream codec-character-stream))
153 (unless (ccs-ensure-buffer stream 1)
154 (return-from stream-peek-char :eof))
155 (with-slots (read-pos buffer) stream
156 (aref buffer read-pos)))
158 (defmethod stream-listen ((stream codec-character-stream))
159 (if (ccs-wont-hang-p stream)
160 (let ((peek (stream-peek-char stream)))
166 (defmethod stream-write-char ((stream codec-character-stream) char)
167 (with-slots (encoder back) stream
168 (let ((seq (make-array '(1) :element-type 'character :initial-element char))
169 (outbuf (make-array '(16) :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0)))
170 (funcall encoder seq outbuf)
171 (write-sequence outbuf back))))
173 (defmethod stream-finish-output ((stream codec-character-stream))
174 (finish-output (slot-value stream 'back)))
176 (defmethod stream-force-output ((stream codec-character-stream))
177 (force-output (slot-value stream 'back)))
179 (defmethod stream-read-sequence ((stream codec-character-stream) seq &optional (start 0) (end (length seq)))
180 (ccs-ensure-buffer stream (- end start))
181 (with-slots (read-pos buffer) stream
182 (replace seq buffer :start1 start :end1 end :start2 read-pos :end2 (length buffer))
183 (let ((len (min (- end start) (- (length buffer) read-pos))))
184 (when (>= (incf read-pos len) 128)
185 (ccs-clear-buffer stream)))))
187 (defmethod stream-write-sequence ((stream codec-character-stream) seq &optional (start 0) (end (length seq)))
188 (with-slots (encoder back) stream
189 (let ((outbuf (make-array (list (- end start)) :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0)))
190 (funcall encoder seq outbuf)
191 (write-sequence outbuf back))))
193 ;;; Implementation-specific functions
195 #+(or (and clisp unicode) sbcl)
196 (defun unicode->char (unicode)
197 (declare (type (unsigned-byte 24) unicode))
200 #+(or (and clisp unicode) sbcl)
201 (defun char->unicode (char)
202 (declare (type character char))
207 (defun decode-ascii (byteseq charseq &key (start 0) (end (length byteseq)))
208 (declare (type (array (unsigned-byte 8)) byteseq)
209 (type (array character) charseq)
210 (type fixnum start end))
214 (unless (< start end) (return-from decode-ascii t))
215 (let ((byte (aref byteseq (prog1 start (incf start)))))
217 (coding-error byteseq start charseq "Invalid byte ~D in ASCII stream." byte))
218 (vector-push-extend (unicode->char byte) charseq)))
219 (:replace-char (&optional (replacement (unicode->char #xfffd)))
220 :report "Replace the invalid byte with a character."
221 (vector-push-extend replacement charseq))
223 :report "Ignore the invalid byte."
226 (defun encode-ascii (charseq byteseq &key (start 0) (end (length charseq)))
227 (declare (type (array (unsigned-byte 8)) byteseq)
228 (type (array character) charseq)
229 (type fixnum start end))
233 (unless (< start end) (return-from encode-ascii t))
234 (vector-push-extend (let ((cp (char->unicode (aref charseq (prog1 start (incf start))))))
236 (coding-error charseq start byteseq "ASCII cannot encode code-points higher than 128."))
239 (:replace-char (&optional (replacement #\?))
240 :report "Replace this character with another."
241 (vector-push-extend (char->unicode replacement) byteseq))
243 :report "Ignore this character."
246 (define-decoder (ascii)
249 (define-encoder (ascii)
252 (define-codec-synonyms ascii :ascii)
256 (defun decode-latin-1 (byteseq charseq &key (start 0) (end (length byteseq)))
257 (declare (type (array (unsigned-byte 8)) byteseq)
258 (type (array character) charseq)
259 (type fixnum start end))
260 (do ((i start (1+ i)))
262 (vector-push-extend (unicode->char (aref byteseq i)) charseq))
265 (defun encode-latin-1 (charseq byteseq &key (start 0) (end (length charseq)))
266 (declare (type (array (unsigned-byte 8)) byteseq)
267 (type (array character) charseq)
268 (type fixnum start end))
272 (unless (< start end) (return-from encode-latin-1 t))
273 (vector-push-extend (let ((cp (char->unicode (aref charseq (prog1 start (incf start))))))
275 (coding-error charseq start byteseq "ISO-8859-1 cannot encode code-points higher than 256."))
278 (:replace-char (&optional (replacement #\?))
279 :report "Replace this character with another."
280 (vector-push-extend (char->unicode replacement) byteseq))
282 :report "Ignore this character."
285 (define-decoder (latin-1)
288 (define-encoder (latin-1)
291 (define-codec-synonyms latin-1 latin1 iso-8859-1 :latin-1 :latin1 :iso-8859-1)
295 (defun encode-utf-8 (charseq byteseq &key (start 0) (end (length charseq)))
296 (declare (type (array (unsigned-byte 8)) byteseq)
297 (type (array character) charseq)
298 (type fixnum start end))
299 (do ((i start (1+ i)))
301 (let ((cp (char->unicode (aref charseq i))))
303 (vector-push-extend cp byteseq)
307 (push (logior (ldb (byte 6 0) cp) #x80) bytes)
308 (setf cp (truncate cp 64))
310 (when (< cp (expt 2 (- 6 nbytes)))
311 (push (logior (logand #xff (lognot (1- (expt 2 (- 7 nbytes)))))
316 (vector-push-extend byte byteseq))))))
319 (define-encoder (utf-8)
322 (define-decoder (utf-8)
325 (flet ((decode (byteseq charseq &key (start 0) (end (length byteseq)))
326 (declare (type (array (unsigned-byte 8)) byteseq)
327 (type (array character) charseq)
328 (type fixnum start end))
330 (flet ((failure (format &rest args)
331 (error 'simple-coding-error
332 :input byteseq :position i :result charseq
333 :format-control format :format-arguments args)))
338 (unless (< i end) (return))
339 (let ((byte (aref byteseq (prog1 i (incf i)))))
342 (vector-push-extend (unicode->char byte) charseq)
343 (setf mlen (block zero
345 (when (= (ldb (byte 1 (- 7 i)) byte) 0)
347 (failure "UTF-8 sequence started with continuation byte: ~D" byte))
348 (return-from zero (1- i))))
349 (failure "Invalid UTF-8 sequence start byte: ~D" byte))
350 mbuf (ldb (byte (- 6 mlen) 0) byte)))
351 (progn (when (not (= (ldb (byte 2 6) byte) 2))
352 (failure "Invalid UTF-8 continuation byte: ~D" byte))
353 (setf mbuf (+ (* mbuf 64) (ldb (byte 6 0) byte)))
354 (when (= (decf mlen) 0)
356 (with-simple-restart (:accept "Accept anyway.")
357 (failure "UTF-8 multibyte sequence denoted an ASCII character ~S (either an encoding error or an attempt at breaking security)." (unicode->char mbuf))))
358 (vector-push-extend (unicode->char mbuf) charseq))))))
359 (return-from decode (= mlen 0)))
360 (:replace-char (&optional (replacement (unicode->char #xfffd)))
361 :report "Replace the invalid bytes with a character."
362 (vector-push-extend replacement charseq)
363 (loop (unless (and (< i end) (= (ldb (byte 2 6) (aref byteseq i)) 2))
368 :report "Ignore the invalid byte sequence."
369 (loop (unless (and (< i end) (= (ldb (byte 2 6) (aref byteseq i)) 2))
375 (define-codec-synonyms utf-8 utf8 :utf-8 :utf8)