;; $Id: mime-transfer-encoding.cl,v 1.3 2006/01/30 18:26:39 layer Exp $
(defpackage :net.post-office
(:use #:lisp #:excl)
(:import-from #:excl #:base64-encode-stream)
(:export
#:base64-encode-stream
#:qp-encode-stream))
(in-package :net.post-office)
;;; Supported transfer encodings
;; encoders
(defun raw-encode-stream (instream outstream)
(declare (optimize (speed 3) (safety 0)))
(let ((buf (make-array 4096 :element-type '(unsigned-byte 8)))
got)
(declare (dynamic-extent buf)
(fixnum got))
(while (/= 0 (setf got (read-vector buf instream)))
(write-vector buf outstream :end got))))
(defconstant *qp-hex-digits* "0123456789ABCDEF")
;; wrap-at is not a hard limit but more of a suggestion. it may be
;; late by by 3 characters.
(defun qp-encode-stream (instream outstream &key (wrap-at 72))
(declare (optimize (speed 3)))
(let ((prev 0)
(outcol 0)
byte)
(declare (fixnum byte prev))
(macrolet ((whitespace (x)
(let ((xx (gensym)))
`(let ((,xx ,x))
(or (= ,xx 9) (= ,xx 32))))))
(labels ((check-linewrap ()
(if* (and wrap-at (>= outcol wrap-at))
then (format outstream "=~%" outstream)
(setf outcol 0)))
(check-deferred ()
(if* (and (= prev 13) (/= byte 10))
then ;; previous byte was bare CR. Handle
(check-linewrap)
(write-string "=0D" outstream)
(incf outcol 3))
(if* (whitespace prev)
then (if* (or (= byte 0) (= byte 10) (= byte 13))
then ;; EOF, EOL, probable EOL. Encode.
(check-linewrap)
(format outstream "=20")
(incf outcol 3)
else ;; Safe to print deferred whitespace
(check-linewrap)
(write-char (code-char prev) outstream)
(incf outcol 1)))))
(while (setf byte (read-byte instream nil nil))
(check-deferred)
(if* (or (and (>= byte 33) (<= byte 60))
(and (>= byte 62) (<= byte 126)))
then (check-linewrap)
(write-char (code-char byte) outstream)
(incf outcol)
elseif (or (= byte 13) (whitespace byte))
thenret ;; defer handling
elseif (= byte 10) ;; LF
then (write-char #\newline outstream)
(setf outcol 0)
else (check-linewrap)
(format outstream "=~c~c"
(schar *qp-hex-digits*
(ash byte -4))
(schar *qp-hex-digits*
(logand byte #xf)))
(incf outcol 3))
(setf prev byte))
;; Handle final deferred data
(setf byte 0)
(check-deferred)))))
#|
(defun mime-decode-transfer-encoding (outstream instream encoding)
(cond
((equalp encoding "quoted-printable")
(decode-quoted-printable outstream instream))
(t
(decode-unmodified outstream instream))))
(defmacro with-decoded-transfer-encoding-stream ((sym instream encoding) &body body)
`(with-function-input-stream (,sym #'mime-decode-transfer-encoding ,instream
,encoding)
,@body))
(defun decoded-part-body-stream-func (outstream instream part)
(with-part-body-stream (part-body-stream instream part)
(mime-decode-transfer-encoding outstream part-body-stream
(mime-part-encoding part))))
(defmacro with-decoded-part-body-stream ((sym instream part) &body body)
`(with-function-input-stream (,sym #'decoded-part-body-stream-func
,instream ,part)
,@body))
;; The decoders
(defun decode-unmodified (outstream instream)
(let (line)
(while (setf line (read-line instream nil nil))
(write-line line outstream))))
(defun decode-quoted-printable (outstream instream)
(declare (optimize (speed 3)))
(let (line max pos char char2 softlinebreak)
(while (setf line (read-line instream nil nil))
(setf max (length line))
(setf pos 0)
(macrolet ((getchar ()
`(if* (>= pos max)
then (setf softlinebreak t)
(return)
else (prog1 (schar line pos) (incf pos)))))
(while (< pos max)
(setf char (getchar))
(if* (char= char #\=)
then ;; If EOL occurs during the attempt to get the next
;; two chars, it will be treated as a soft line break.
(setf char (getchar))
(setf char2 (getchar))
(let ((value (logior
(ash (or (position char *qp-hex-digits*) -1) 4)
(or (position char2 *qp-hex-digits*) -1))))
(if* (> value -1)
then
(write-byte value outstream)
else
;; We got some bogus input. Leave it untouched
(write-char #\= outstream)
(write-char char outstream)
(write-char char2 outstream)))
else (write-char char outstream)))
(if* softlinebreak
then (setf softlinebreak nil)
else (write-char #\newline outstream))))))
|#