;;;; representations thereof
(defpackage :charcode
- (:use :cl #+sbcl :sb-gray #-sbcl :gray)
- (:export "MAKE-ENCODER" "MAKE-DECODER" "ENCODE-STRING" "DECODE-STRING"
- "CODING-ERROR"
- "LATIN-1" "LATIN1" "UTF-8" "UTF8"))
+ (:use :cl)
+ (:export "MAKE-ENCODER" "MAKE-DECODER" "ENCODE-STRING" "DECODE-STRING" "SYSTEM-CHARSET"
+ "NO-CODEC-ERROR" "CODING-ERROR"
+ "MAKE-CODEC-CHARACTER-STREAM"
+ "ASCII" "LATIN-1" "LATIN1" "UTF-8" "UTF8"))
(in-package :charcode)
;;; General stuff
+(define-condition no-codec-error (error)
+ ((codec-name :initarg :codec-name))
+ (:report (lambda (c s)
+ (with-slots (codec-name) c
+ (format s "Could find no codec named ~A." codec-name)))))
+
(define-condition coding-error (error)
((input :initarg :input)
(position :initarg :position)
synonyms)))
(defun make-encoder (name)
- (the encoder-fun (values (funcall (get name 'make-encoder)))))
+ (the encoder-fun (values (funcall (or (get name 'make-encoder)
+ (error 'no-codec-error :codec-name name))))))
(defun make-decoder (name)
- (the decoder-fun (values (funcall (get name 'make-decoder)))))
+ (the decoder-fun (values (funcall (or (get name 'make-decoder)
+ (error 'no-codec-error :codec-name name))))))
+
+(defun system-charset ()
+ ;; XXX: Replace me with something perhaps more sensible.
+ 'utf-8)
-(defun encode-string (string coding)
+(defun encode-string (string &optional (coding (system-charset)))
(declare (type string string))
(let ((encoder (make-encoder coding))
(buf (make-array (list (length string)) :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0)))
(coding-error string (length string) buf "Encoding of string in ~A ended prematurely." coding))
buf))
-(defun decode-string (buffer coding)
+(defun decode-string (buffer &optional (coding (system-charset)))
(declare (type (array (unsigned-byte 8)) buffer))
(let ((decoder (make-decoder coding))
(buf (make-array (list (length buffer)) :element-type 'character :adjustable t :fill-pointer 0)))
;;; Gray stream implementation
+;; Disabled for now. There doesn't seem to be any good way to get
+;; these working generally over various implementations.
+
+#+unused (
(defclass codec-character-stream (fundamental-character-input-stream fundamental-character-output-stream)
((decoder :initarg :decoder)
(encoder :initarg :encoder)
(read-pos :initform 0)
(buffer :initform (make-array '(64) :element-type 'character :adjustable t :fill-pointer 0))))
+(defun make-codec-character-stream (real-stream &optional (charset (system-charset)))
+ (declare (type stream real-stream))
+ (make-instance 'codec-character-stream :decoder (make-decoder charset) :encoder (make-encoder charset) :back real-stream))
+
(defmethod close ((stream codec-character-stream) &key abort)
(with-slots (back) stream
(close back :abort abort))
(with-slots (decoder back buffer read-pos) stream
(let ((readbuf (make-array (list len) :element-type '(unsigned-byte 8))))
(loop (unless (< (- (length buffer) read-pos) len) (return t))
- (let ((readlen (read-sequence readbuf back)))
+ (let ((readlen (read-sequence readbuf back :end (- len (- (length buffer) read-pos)))))
(when (= readlen 0)
(return-from ccs-ensure-buffer nil))
(funcall decoder readbuf buffer :end readlen))))))
(declare (type codec-character-stream stream))
(with-slots (read-pos buffer) stream
(replace buffer buffer :start2 read-pos)
- (setf (fill-pointer buffer) (- (fill-pointer buffer) read-pos)
- read-pos 0)))
+ (setf (fill-pointer buffer) (- (fill-pointer buffer) read-pos)
+ read-pos 0)))
(defmethod stream-read-char ((stream codec-character-stream))
(unless (ccs-ensure-buffer stream 1)
(adjust-array buffer (list (setf (fill-pointer buffer)
(+ len 16)))))
(replace buffer buffer :start1 16 :end2 len)))
- (setf (aref buffer read-pos) char)
- (decf read-pos)
+ (setf (aref buffer (decf read-pos)) char)
nil))
(defun ccs-wont-hang-p (stream)
(let ((outbuf (make-array (list (- end start)) :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0)))
(funcall encoder seq outbuf)
(write-sequence outbuf back))))
+)
;;; Implementation-specific functions
-#+(or (and clisp unicode) sbcl)
+#+(or (and clisp unicode) sbcl abcl)
(defun unicode->char (unicode)
(declare (type (unsigned-byte 24) unicode))
(code-char unicode))
-#+(or (and clisp unicode) sbcl)
+#+(or (and clisp unicode) sbcl abcl)
(defun char->unicode (char)
(declare (type character char))
(char-code char))
+#+ecl
+(defun unicode->char (unicode)
+ (declare (type (unsigned-byte 24) unicode))
+ (when (>= unicode 256)
+ (error "ECL does not handle Unicode characters outside Latin-1."))
+ (code-char unicode))
+
+#+ecl
+(defun char->unicode (char)
+ (declare (type character char))
+ (char-code char))
+
+;;; ASCII
+
+(defun decode-ascii (byteseq charseq &key (start 0) (end (length byteseq)))
+ (declare (type (array (unsigned-byte 8)) byteseq)
+ (type (array character) charseq)
+ (type fixnum start end))
+ (loop
+ (restart-case
+ (loop
+ (unless (< start end) (return-from decode-ascii t))
+ (let ((byte (aref byteseq (prog1 start (incf start)))))
+ (unless (< byte 128)
+ (coding-error byteseq start charseq "Invalid byte ~D in ASCII stream." byte))
+ (vector-push-extend (unicode->char byte) charseq)))
+ (:replace-char (&optional (replacement (unicode->char #xfffd)))
+ :report "Replace the invalid byte with a character."
+ (vector-push-extend replacement charseq))
+ (:skip-char ()
+ :report "Ignore the invalid byte."
+ nil))))
+
+(defun encode-ascii (charseq byteseq &key (start 0) (end (length charseq)))
+ (declare (type (array (unsigned-byte 8)) byteseq)
+ (type (array character) charseq)
+ (type fixnum start end))
+ (loop
+ (restart-case
+ (loop
+ (unless (< start end) (return-from encode-ascii t))
+ (vector-push-extend (let ((cp (char->unicode (aref charseq (prog1 start (incf start))))))
+ (unless (< cp 128)
+ (coding-error charseq start byteseq "ASCII cannot encode code-points higher than 128."))
+ cp)
+ byteseq))
+ (:replace-char (&optional (replacement #\?))
+ :report "Replace this character with another."
+ (vector-push-extend (char->unicode replacement) byteseq))
+ (:skip-char ()
+ :report "Ignore this character."
+ nil))))
+
+(define-decoder (ascii)
+ #'decode-ascii)
+
+(define-encoder (ascii)
+ #'encode-ascii)
+
+(define-codec-synonyms ascii :ascii)
+
;;; Latin-1
(defun decode-latin-1 (byteseq charseq &key (start 0) (end (length byteseq)))
(define-encoder (latin-1)
#'encode-latin-1)
-(define-codec-synonyms latin-1 latin1 iso-8859-1)
+(define-codec-synonyms latin-1 latin1 iso-8859-1 :latin-1 :latin1 :iso-8859-1)
;;; UTF-8
(setf mlen 0))))))))
#'decode)))
-(define-codec-synonyms utf-8 utf8)
+(define-codec-synonyms utf-8 utf8 :utf-8 :utf8)
Dolda2000 GitWeb / lisp-utils.git / blobdiff