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