charcode.lisp

   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)