Added strict ASCII codec.
[lisp-utils.git] / charcode.lisp
... / ...
CommitLineData
1;;;; CHAR-CODE -- Conversions between characters and byte
2;;;; representations thereof
3
4(defpackage :charcode
5 (:use :cl #+sbcl :sb-gray #-sbcl :gray)
6 (:export "MAKE-ENCODER" "MAKE-DECODER" "ENCODE-STRING" "DECODE-STRING" "SYSTEM-CHARSET"
7 "CODING-ERROR"
8 "MAKE-CODEC-CHARACTER-STREAM"
9 "ASCII" "LATIN-1" "LATIN1" "UTF-8" "UTF8"))
10(in-package :charcode)
11
12;;; General stuff
13
14(define-condition coding-error (error)
15 ((input :initarg :input)
16 (position :initarg :position)
17 (result :initarg :result)))
18
19(define-condition simple-coding-error (coding-error simple-error) ())
20
21(defun coding-error (input position result format &rest format-args)
22 (error 'simple-coding-error
23 :input input :position position :result result
24 :format-control format :format-arguments format-args))
25
26(deftype decoder-fun () `(function ((array (unsigned-byte 8))
27 (array character)
28 &key (start fixnum) (end fixnum))
29 (member t nil)))
30(deftype encoder-fun () `(function ((array character)
31 (array (unsigned-byte 8))
32 &key (start fixnum) (end fixnum))
33 (member t nil)))
34
35(defmacro define-encoder ((name) &body make-encoder)
36 `(setf (get ',name 'make-encoder) #'(lambda () ,@make-encoder)))
37
38(defmacro define-decoder ((name) &body make-decoder)
39 `(setf (get ',name 'make-decoder) #'(lambda () ,@make-decoder)))
40
41(defmacro define-codec-synonyms (name &rest synonyms)
42 `(eval-when (:load-toplevel :execute)
43 ,@(mapcar #'(lambda (sym)
44 `(setf (get ',sym 'make-encoder) (get ',name 'make-encoder)
45 (get ',sym 'make-decoder) (get ',name 'make-decoder)))
46 synonyms)))
47
48(defun make-encoder (name)
49 (the encoder-fun (values (funcall (get name 'make-encoder)))))
50
51(defun make-decoder (name)
52 (the decoder-fun (values (funcall (get name 'make-decoder)))))
53
54(defun system-charset ()
55 ;; XXX: Replace me with something perhaps more sensible.
56 'utf-8)
57
58(defun encode-string (string &optional (coding (system-charset)))
59 (declare (type string string))
60 (let ((encoder (make-encoder coding))
61 (buf (make-array (list (length string)) :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0)))
62 (unless (funcall encoder string buf)
63 (coding-error string (length string) buf "Encoding of string in ~A ended prematurely." coding))
64 buf))
65
66(defun decode-string (buffer &optional (coding (system-charset)))
67 (declare (type (array (unsigned-byte 8)) buffer))
68 (let ((decoder (make-decoder coding))
69 (buf (make-array (list (length buffer)) :element-type 'character :adjustable t :fill-pointer 0)))
70 (unless (funcall decoder buffer buf)
71 (coding-error buffer (length buffer) buf "~A byte sequence ended prematurely." coding))
72 buf))
73
74;;; Gray stream implementation
75
76(defclass codec-character-stream (fundamental-character-input-stream fundamental-character-output-stream)
77 ((decoder :initarg :decoder)
78 (encoder :initarg :encoder)
79 (back :initarg :back)
80 (read-pos :initform 0)
81 (buffer :initform (make-array '(64) :element-type 'character :adjustable t :fill-pointer 0))))
82
83(defun make-codec-character-stream (real-stream &optional (charset (system-charset)))
84 (declare (type stream real-stream))
85 (make-instance 'codec-character-stream :decoder (make-decoder charset) :encoder (make-encoder charset) :back real-stream))
86
87(defmethod close ((stream codec-character-stream) &key abort)
88 (with-slots (back) stream
89 (close back :abort abort))
90 (call-next-method))
91
92(defmethod open-stream-p ((stream codec-character-stream))
93 (with-slots (back) stream
94 (open-stream-p stream)))
95
96(defun ccs-ensure-buffer (stream len)
97 (declare (type codec-character-stream stream)
98 (type integer len))
99 (with-slots (decoder back buffer read-pos) stream
100 (let ((readbuf (make-array (list len) :element-type '(unsigned-byte 8))))
101 (loop (unless (< (- (length buffer) read-pos) len) (return t))
102 (let ((readlen (read-sequence readbuf back)))
103 (when (= readlen 0)
104 (return-from ccs-ensure-buffer nil))
105 (funcall decoder readbuf buffer :end readlen))))))
106
107(defun ccs-clear-buffer (stream)
108 (declare (type codec-character-stream stream))
109 (with-slots (read-pos buffer) stream
110 (replace buffer buffer :start2 read-pos)
111 (setf (fill-pointer buffer) (- (fill-pointer buffer) read-pos)
112 read-pos 0)))
113
114(defmethod stream-read-char ((stream codec-character-stream))
115 (unless (ccs-ensure-buffer stream 1)
116 (return-from stream-read-char :eof))
117 (with-slots (read-pos buffer) stream
118 (prog1 (aref buffer read-pos)
119 (when (>= (incf read-pos) 16)
120 (ccs-clear-buffer stream)))))
121
122(defmethod stream-unread-char ((stream codec-character-stream) char)
123 (with-slots (read-pos buffer) stream
124 (when (= read-pos 0)
125 (let ((len (length buffer)))
126 (when (< (array-dimension buffer 0) (+ len 16))
127 (adjust-array buffer (list (setf (fill-pointer buffer)
128 (+ len 16)))))
129 (replace buffer buffer :start1 16 :end2 len)))
130 (setf (aref buffer read-pos) char)
131 (decf read-pos)
132 nil))
133
134(defun ccs-wont-hang-p (stream)
135 (declare (type codec-character-stream stream))
136 (with-slots (read-pos back buffer) stream
137 (or (and (< read-pos (length buffer)) (aref buffer read-pos))
138 (listen back))))
139
140(defmethod stream-read-char-no-hang ((stream codec-character-stream))
141 (if (ccs-wont-hang-p stream)
142 (stream-read-char stream)
143 nil))
144
145(defmethod stream-peek-char ((stream codec-character-stream))
146 (unless (ccs-ensure-buffer stream 1)
147 (return-from stream-peek-char :eof))
148 (with-slots (read-pos buffer) stream
149 (aref buffer read-pos)))
150
151(defmethod stream-listen ((stream codec-character-stream))
152 (if (ccs-wont-hang-p stream)
153 (let ((peek (stream-peek-char stream)))
154 (if (eq peek :eof)
155 nil
156 peek))
157 nil))
158
159(defmethod stream-write-char ((stream codec-character-stream) char)
160 (with-slots (encoder back) stream
161 (let ((seq (make-array '(1) :element-type 'character :initial-element char))
162 (outbuf (make-array '(16) :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0)))
163 (funcall encoder seq outbuf)
164 (write-sequence outbuf back))))
165
166(defmethod stream-finish-output ((stream codec-character-stream))
167 (finish-output (slot-value stream 'back)))
168
169(defmethod stream-force-output ((stream codec-character-stream))
170 (force-output (slot-value stream 'back)))
171
172(defmethod stream-read-sequence ((stream codec-character-stream) seq &optional (start 0) (end (length seq)))
173 (ccs-ensure-buffer stream (- end start))
174 (with-slots (read-pos buffer) stream
175 (replace seq buffer :start1 start :end1 end :start2 read-pos :end2 (length buffer))
176 (let ((len (min (- end start) (- (length buffer) read-pos))))
177 (when (>= (incf read-pos len) 128)
178 (ccs-clear-buffer stream)))))
179
180(defmethod stream-write-sequence ((stream codec-character-stream) seq &optional (start 0) (end (length seq)))
181 (with-slots (encoder back) stream
182 (let ((outbuf (make-array (list (- end start)) :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0)))
183 (funcall encoder seq outbuf)
184 (write-sequence outbuf back))))
185
186;;; Implementation-specific functions
187
188#+(or (and clisp unicode) sbcl)
189(defun unicode->char (unicode)
190 (declare (type (unsigned-byte 24) unicode))
191 (code-char unicode))
192
193#+(or (and clisp unicode) sbcl)
194(defun char->unicode (char)
195 (declare (type character char))
196 (char-code char))
197
198;;; ASCII
199
200(defun decode-ascii (byteseq charseq &key (start 0) (end (length byteseq)))
201 (declare (type (array (unsigned-byte 8)) byteseq)
202 (type (array character) charseq)
203 (type fixnum start end))
204 (loop
205 (restart-case
206 (loop
207 (unless (< start end) (return-from decode-ascii t))
208 (let ((byte (aref byteseq (prog1 start (incf start)))))
209 (unless (< byte 128)
210 (coding-error byteseq start charseq "Invalid byte ~D in ASCII stream." byte))
211 (vector-push-extend (unicode->char byte) charseq)))
212 (:replace-char (&optional (replacement (unicode->char #xfffd)))
213 :report "Replace the invalid byte with a character."
214 (vector-push-extend replacement charseq))
215 (:skip-char ()
216 :report "Ignore the invalid byte."
217 nil))))
218
219(defun encode-ascii (charseq byteseq &key (start 0) (end (length charseq)))
220 (declare (type (array (unsigned-byte 8)) byteseq)
221 (type (array character) charseq)
222 (type fixnum start end))
223 (loop
224 (restart-case
225 (loop
226 (unless (< start end) (return-from encode-ascii t))
227 (vector-push-extend (let ((cp (char->unicode (aref charseq (prog1 start (incf start))))))
228 (unless (< cp 128)
229 (coding-error charseq start byteseq "ASCII cannot encode code-points higher than 128."))
230 cp)
231 byteseq))
232 (:replace-char (&optional (replacement #\?))
233 :report "Replace this character with another."
234 (vector-push-extend (char->unicode replacement) byteseq))
235 (:skip-char ()
236 :report "Ignore this character."
237 nil))))
238
239(define-decoder (ascii)
240 #'decode-ascii)
241
242(define-encoder (ascii)
243 #'encode-ascii)
244
245;;; Latin-1
246
247(defun decode-latin-1 (byteseq charseq &key (start 0) (end (length byteseq)))
248 (declare (type (array (unsigned-byte 8)) byteseq)
249 (type (array character) charseq)
250 (type fixnum start end))
251 (do ((i start (1+ i)))
252 ((>= i end))
253 (vector-push-extend (unicode->char (aref byteseq i)) charseq))
254 t)
255
256(defun encode-latin-1 (charseq byteseq &key (start 0) (end (length charseq)))
257 (declare (type (array (unsigned-byte 8)) byteseq)
258 (type (array character) charseq)
259 (type fixnum start end))
260 (loop
261 (restart-case
262 (loop
263 (unless (< start end) (return-from encode-latin-1 t))
264 (vector-push-extend (let ((cp (char->unicode (aref charseq (prog1 start (incf start))))))
265 (unless (< cp 256)
266 (coding-error charseq start byteseq "ISO-8859-1 cannot encode code-points higher than 256."))
267 cp)
268 byteseq))
269 (:replace-char (&optional (replacement #\?))
270 :report "Replace this character with another."
271 (vector-push-extend (char->unicode replacement) byteseq))
272 (:skip-char ()
273 :report "Ignore this character."
274 nil))))
275
276(define-decoder (latin-1)
277 #'decode-latin-1)
278
279(define-encoder (latin-1)
280 #'encode-latin-1)
281
282(define-codec-synonyms latin-1 latin1 iso-8859-1)
283
284;;; UTF-8
285
286(defun encode-utf-8 (charseq byteseq &key (start 0) (end (length charseq)))
287 (declare (type (array (unsigned-byte 8)) byteseq)
288 (type (array character) charseq)
289 (type fixnum start end))
290 (do ((i start (1+ i)))
291 ((>= i end))
292 (let ((cp (char->unicode (aref charseq i))))
293 (if (< cp 128)
294 (vector-push-extend cp byteseq)
295 (let ((nbytes 0)
296 (bytes '()))
297 (loop
298 (push (logior (ldb (byte 6 0) cp) #x80) bytes)
299 (setf cp (truncate cp 64))
300 (incf nbytes)
301 (when (< cp (expt 2 (- 6 nbytes)))
302 (push (logior (logand #xff (lognot (1- (expt 2 (- 7 nbytes)))))
303 cp)
304 bytes)
305 (return)))
306 (dolist (byte bytes)
307 (vector-push-extend byte byteseq))))))
308 t)
309
310(define-encoder (utf-8)
311 #'encode-utf-8)
312
313(define-decoder (utf-8)
314 (let ((mbuf 0)
315 (mlen 0))
316 (flet ((decode (byteseq charseq &key (start 0) (end (length byteseq)))
317 (declare (type (array (unsigned-byte 8)) byteseq)
318 (type (array character) charseq)
319 (type fixnum start end))
320 (let ((i start))
321 (flet ((failure (format &rest args)
322 (error 'simple-coding-error
323 :input byteseq :position i :result charseq
324 :format-control format :format-arguments args)))
325 (loop
326 (restart-case
327 (progn
328 (loop
329 (unless (< i end) (return))
330 (let ((byte (aref byteseq (prog1 i (incf i)))))
331 (if (= mlen 0)
332 (if (< byte 128)
333 (vector-push-extend (unicode->char byte) charseq)
334 (setf mlen (block zero
335 (dotimes (i 7)
336 (when (= (ldb (byte 1 (- 7 i)) byte) 0)
337 (when (< i 2)
338 (failure "UTF-8 sequence started with continuation byte: ~D" byte))
339 (return-from zero (1- i))))
340 (failure "Invalid UTF-8 sequence start byte: ~D" byte))
341 mbuf (ldb (byte (- 6 mlen) 0) byte)))
342 (progn (when (not (= (ldb (byte 2 6) byte) 2))
343 (failure "Invalid UTF-8 continuation byte: ~D" byte))
344 (setf mbuf (+ (* mbuf 64) (ldb (byte 6 0) byte)))
345 (when (= (decf mlen) 0)
346 (when (< mbuf 128)
347 (with-simple-restart (:accept "Accept anyway.")
348 (failure "UTF-8 multibyte sequence denoted an ASCII character ~S (either an encoding error or an attempt at breaking security)." (unicode->char mbuf))))
349 (vector-push-extend (unicode->char mbuf) charseq))))))
350 (return-from decode (= mlen 0)))
351 (:replace-char (&optional (replacement (unicode->char #xfffd)))
352 :report "Replace the invalid bytes with a character."
353 (vector-push-extend replacement charseq)
354 (loop (unless (and (< i end) (= (ldb (byte 2 6) (aref byteseq i)) 2))
355 (return))
356 (incf i))
357 (setf mlen 0))
358 (:skip-char ()
359 :report "Ignore the invalid byte sequence."
360 (loop (unless (and (< i end) (= (ldb (byte 2 6) (aref byteseq i)) 2))
361 (return))
362 (incf i))
363 (setf mlen 0))))))))
364 #'decode)))
365
366(define-codec-synonyms utf-8 utf8)