chore(3p/lisp): import mime4cl source tarball
Used http://wcp.sdf-eu.org/software/mime4cl-20150207T211851.tbz (sha256 5a914669bba7561efe59a4fd0817204c07ad2add98b03ae206ef185ac04affb3). Importing seems sensible since there's no upstream repo nor has their been a release since 2015. This is just an import commit, so the changes made to make it build are more discoverable as their own commit. Change-Id: I2ff28c3c7433abdf7857204bc89eaf9edc0b1cbc Reviewed-on: https://cl.tvl.fyi/c/depot/+/3378 Tested-by: BuildkiteCI Reviewed-by: grfn <grfn@gws.fyi>
This commit is contained in:
sterni
parent
de0f0164d2
commit
901364869c
13 changed files with 3313 additions and 0 deletions
683
third_party/lisp/mime4cl/endec.lisp
vendored
Normal file
683
third_party/lisp/mime4cl/endec.lisp
vendored
Normal file
|
|
@ -0,0 +1,683 @@
|
|||
;;; endec.lisp --- encoder/decoder functions
|
||||
|
||||
;;; Copyright (C) 2005-2008, 2010 by Walter C. Pelissero
|
||||
|
||||
;;; Author: Walter C. Pelissero <walter@pelissero.de>
|
||||
;;; Project: mime4cl
|
||||
|
||||
;;; This library is free software; you can redistribute it and/or
|
||||
;;; modify it under the terms of the GNU Lesser General Public License
|
||||
;;; as published by the Free Software Foundation; either version 2.1
|
||||
;;; of the License, or (at your option) any later version.
|
||||
;;; This library is distributed in the hope that it will be useful,
|
||||
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;;; Lesser General Public License for more details.
|
||||
;;; You should have received a copy of the GNU Lesser General Public
|
||||
;;; License along with this library; if not, write to the Free
|
||||
;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
|
||||
;;; 02111-1307 USA
|
||||
|
||||
|
||||
(in-package :mime4cl)
|
||||
|
||||
|
||||
;; Thank you SBCL for rendering constants totally useless!
|
||||
(defparameter +base64-encode-table+
|
||||
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=")
|
||||
|
||||
(defparameter +base64-decode-table+
|
||||
(let ((da (make-array 256 :element-type '(unsigned-byte 8) :initial-element 65)))
|
||||
(dotimes (i 64)
|
||||
(setf (aref da (char-code (char +base64-encode-table+ i))) i))
|
||||
da))
|
||||
|
||||
(declaim (type (simple-array (unsigned-byte 8)) +base64-decode-table+)
|
||||
(type simple-string +base64-encode-table+))
|
||||
|
||||
(defvar *base64-line-length* 76
|
||||
"Maximum length of the encoded base64 line. NIL means it can
|
||||
be of unlimited length \(no line breaks will be done by the
|
||||
encoding function).")
|
||||
|
||||
(defvar *quoted-printable-line-length* 72
|
||||
"Maximum length of the encoded quoted printable line. NIL
|
||||
means it can be of unlimited length \(no line breaks will be done
|
||||
by the encoding function).")
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defclass decoder ()
|
||||
((input-function :initarg :input-function
|
||||
:reader decoder-input-function
|
||||
:type function
|
||||
:documentation
|
||||
"Function is called repeatedly by the decoder methods to get the next character.
|
||||
It should return a character os NIL (indicating EOF)."))
|
||||
(:documentation
|
||||
"Abstract base class for decoders."))
|
||||
|
||||
(defclass parsing-decoder (decoder)
|
||||
((parser-errors :initform nil
|
||||
:initarg :parser-errors
|
||||
:reader decoder-parser-errors
|
||||
:type boolean))
|
||||
(:documentation
|
||||
"Abstract base class for decoders that do parsing."))
|
||||
|
||||
(defclass encoder ()
|
||||
((output-function :initarg :output-function
|
||||
:reader encoder-output-function
|
||||
:type function
|
||||
:documentation
|
||||
"Function is called repeatedly by the encoder methods to output a character.
|
||||
It should expect a character as its only argument."))
|
||||
(:documentation
|
||||
"Abstract base class for encoders."))
|
||||
|
||||
(defclass line-encoder (encoder)
|
||||
((column :initform 0
|
||||
:type fixnum)
|
||||
(line-length :initarg :line-length
|
||||
:initform nil
|
||||
:reader encoder-line-length
|
||||
:type (or fixnum null)))
|
||||
(:documentation
|
||||
"Abstract base class for line encoders."))
|
||||
|
||||
(defclass 8bit-decoder (decoder)
|
||||
()
|
||||
(:documentation
|
||||
"Class for decoders that do nothing."))
|
||||
|
||||
(defclass 8bit-encoder (encoder)
|
||||
()
|
||||
(:documentation
|
||||
"Class for encoders that do nothing."))
|
||||
|
||||
(defclass 7bit-decoder (decoder)
|
||||
()
|
||||
(:documentation
|
||||
"Class for decoders that do nothing."))
|
||||
|
||||
(defclass 7bit-encoder (encoder)
|
||||
()
|
||||
(:documentation
|
||||
"Class for encoders that do nothing."))
|
||||
|
||||
(defclass byte-decoder (decoder)
|
||||
()
|
||||
(:documentation
|
||||
"Class for decoders that turns chars to bytes."))
|
||||
|
||||
(defclass byte-encoder (encoder)
|
||||
()
|
||||
(:documentation
|
||||
"Class for encoders that turns bytes to chars."))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defgeneric encoder-write-byte (encoder byte))
|
||||
(defgeneric encoder-finish-output (encoder))
|
||||
(defgeneric decoder-read-byte (decoder))
|
||||
|
||||
(defmethod encoder-finish-output ((encoder encoder))
|
||||
(values))
|
||||
|
||||
(defmethod encoder-write-byte ((encoder 8bit-encoder) byte)
|
||||
(funcall (slot-value encoder 'output-function)
|
||||
(code-char byte))
|
||||
(values))
|
||||
|
||||
(defmethod decoder-read-byte ((decoder 8bit-decoder))
|
||||
(awhen (funcall (slot-value decoder 'input-function))
|
||||
(char-code it)))
|
||||
|
||||
(defmethod encoder-write-byte ((encoder 7bit-encoder) byte)
|
||||
(funcall (slot-value encoder 'output-function)
|
||||
(code-char (logand #x7F byte)))
|
||||
(values))
|
||||
|
||||
(defmethod decoder-read-byte ((decoder 7bit-decoder))
|
||||
(awhen (funcall (slot-value decoder 'input-function))
|
||||
(logand #x7F (char-code it))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defun decoder-read-sequence (sequence decoder &key (start 0) (end (length sequence)))
|
||||
(declare (optimize (speed 3) (safety 0) (debug 0))
|
||||
(type fixnum start end)
|
||||
(type vector sequence))
|
||||
(loop
|
||||
for i fixnum from start below end
|
||||
for byte = (decoder-read-byte decoder)
|
||||
while byte
|
||||
do (setf (aref sequence i) byte)
|
||||
finally (return i)))
|
||||
|
||||
(defun decoder-read-line (decoder)
|
||||
(with-output-to-string (str)
|
||||
(loop
|
||||
for byte = (decoder-read-byte decoder)
|
||||
unless byte
|
||||
do (return-from decoder-read-line nil)
|
||||
do (be c (code-char byte)
|
||||
(cond ((char= c #\return)
|
||||
;; skip the newline
|
||||
(decoder-read-byte decoder)
|
||||
(return nil))
|
||||
((char= c #\newline)
|
||||
;; the #\return was missing
|
||||
(return nil))
|
||||
(t (write-char c str)))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(declaim (inline parse-hex))
|
||||
(defun parse-hex (c1 c2)
|
||||
"Parse two characters as hexadecimal and return their combined
|
||||
value."
|
||||
(declare (optimize (speed 3) (safety 0) (debug 0))
|
||||
(type character c1 c2))
|
||||
(flet ((digit-value (char)
|
||||
(or (position char "0123456789ABCDEF")
|
||||
(return-from parse-hex nil))))
|
||||
(+ (* 16 (digit-value c1))
|
||||
(digit-value c2))))
|
||||
|
||||
(defclass quoted-printable-decoder (parsing-decoder)
|
||||
((saved-bytes :initform (make-queue))))
|
||||
|
||||
(defmethod decoder-read-byte ((decoder quoted-printable-decoder))
|
||||
(declare (optimize (speed 3) (safety 0) (debug 0)))
|
||||
(with-slots (input-function saved-bytes parser-errors) decoder
|
||||
(declare (type function input-function))
|
||||
(labels ((saveb (b)
|
||||
(queue-append saved-bytes b)
|
||||
(values))
|
||||
(save (c)
|
||||
(saveb (char-code c)))
|
||||
(push-next ()
|
||||
(be c (funcall input-function)
|
||||
(declare (type (or null character) c))
|
||||
(cond ((not c))
|
||||
((or (char= c #\space)
|
||||
(char= c #\tab))
|
||||
(save c)
|
||||
(push-next))
|
||||
((char= c #\=)
|
||||
(be c1 (funcall input-function)
|
||||
(cond ((not c1)
|
||||
(save #\=))
|
||||
((char= c1 #\return)
|
||||
;; soft line break: skip the next
|
||||
;; character which we assume to be a
|
||||
;; newline (pity if it isn't)
|
||||
(funcall input-function)
|
||||
(push-next))
|
||||
((char= c1 #\newline)
|
||||
;; soft line break: the #\return is
|
||||
;; missing, but we are tolerant
|
||||
(push-next))
|
||||
(t
|
||||
;; hexadecimal sequence: get the 2nd digit
|
||||
(be c2 (funcall input-function)
|
||||
(if c2
|
||||
(aif (parse-hex c1 c2)
|
||||
(saveb it)
|
||||
(if parser-errors
|
||||
(error "invalid hex sequence ~A~A" c1 c2)
|
||||
(progn
|
||||
(save #\=)
|
||||
(save c1)
|
||||
(save c2))))
|
||||
(progn
|
||||
(save c)
|
||||
(save c1))))))))
|
||||
(t
|
||||
(save c))))))
|
||||
(or (queue-pop saved-bytes)
|
||||
(progn
|
||||
(push-next)
|
||||
(queue-pop saved-bytes))))))
|
||||
|
||||
(defmacro make-encoder-loop (encoder-class input-form output-form)
|
||||
(with-gensyms (encoder byte)
|
||||
`(loop
|
||||
with ,encoder = (make-instance ',encoder-class
|
||||
:output-function #'(lambda (char) ,output-form))
|
||||
for ,byte = ,input-form
|
||||
while ,byte
|
||||
do (encoder-write-byte ,encoder ,byte)
|
||||
finally (encoder-finish-output ,encoder))))
|
||||
|
||||
(defmacro make-decoder-loop (decoder-class input-form output-form &key parser-errors)
|
||||
(with-gensyms (decoder)
|
||||
`(loop
|
||||
with ,decoder = (make-instance ',decoder-class
|
||||
:input-function #'(lambda () ,input-form)
|
||||
:parser-errors ,parser-errors)
|
||||
for byte = (decoder-read-byte ,decoder)
|
||||
while byte
|
||||
do ,output-form)))
|
||||
|
||||
(defun decode-quoted-printable-stream (in out &key parser-errors)
|
||||
"Read from stream IN a quoted printable text and write to
|
||||
binary output OUT the decoded stream of bytes."
|
||||
(make-decoder-loop quoted-printable-decoder
|
||||
(read-byte in nil) (write-byte byte out)
|
||||
:parser-errors parser-errors))
|
||||
|
||||
(defmacro make-stream-to-sequence-decoder (decoder-class input-form &key parser-errors)
|
||||
"Decode the character stream STREAM and return a sequence of bytes."
|
||||
(with-gensyms (output-sequence)
|
||||
`(be ,output-sequence (make-array 0
|
||||
:element-type '(unsigned-byte 8)
|
||||
:fill-pointer 0
|
||||
:adjustable t)
|
||||
(make-decoder-loop ,decoder-class ,input-form
|
||||
(vector-push-extend byte ,output-sequence)
|
||||
:parser-errors ,parser-errors)
|
||||
,output-sequence)))
|
||||
|
||||
(defun decode-quoted-printable-stream-to-sequence (stream &key parser-errors)
|
||||
"Read from STREAM a quoted printable text and return a vector of
|
||||
bytes."
|
||||
(make-stream-to-sequence-decoder quoted-printable-decoder
|
||||
(read-char stream nil)
|
||||
:parser-errors parser-errors))
|
||||
|
||||
(defun decode-quoted-printable-string (string &key (start 0) (end (length string)) parser-errors)
|
||||
"Decode STRING as quoted printable sequence of characters and
|
||||
return a decoded sequence of bytes."
|
||||
(with-input-from-string (in string :start start :end end)
|
||||
(decode-quoted-printable-stream-to-sequence in :parser-errors parser-errors)))
|
||||
|
||||
(defclass quoted-printable-encoder (line-encoder)
|
||||
((line-length :initform *quoted-printable-line-length*
|
||||
:type (or fixnum null))
|
||||
(pending-space :initform nil
|
||||
:type boolean)))
|
||||
|
||||
(defmethod encoder-write-byte ((encoder quoted-printable-encoder) byte)
|
||||
(declare (optimize (speed 3) (safety 0) (debug 0))
|
||||
(type (unsigned-byte 8) byte))
|
||||
(with-slots (output-function column pending-space line-length) encoder
|
||||
(declare (type function output-function)
|
||||
(type fixnum column)
|
||||
(type (or fixnum null) line-length)
|
||||
(type boolean pending-space))
|
||||
(labels ((out (c)
|
||||
(funcall output-function c)
|
||||
(values))
|
||||
(outs (str)
|
||||
(declare (type simple-string str))
|
||||
(loop
|
||||
for c across str
|
||||
do (out c))
|
||||
(values))
|
||||
(out2hex (x)
|
||||
(declare (type fixnum x))
|
||||
(multiple-value-bind (a b) (truncate x 16)
|
||||
(out (digit-char a 16))
|
||||
(out (digit-char b 16)))))
|
||||
(cond ((= byte #.(char-code #\newline))
|
||||
(when pending-space
|
||||
(outs "=20")
|
||||
(setf pending-space nil))
|
||||
(out #\newline)
|
||||
(setf column 0))
|
||||
((= byte #.(char-code #\space))
|
||||
(if pending-space
|
||||
(progn
|
||||
(out #\space)
|
||||
(f++ column))
|
||||
(setf pending-space t)))
|
||||
(t
|
||||
(when pending-space
|
||||
(out #\space)
|
||||
(f++ column)
|
||||
(setf pending-space nil))
|
||||
(cond ((or (< byte 32)
|
||||
(= byte #.(char-code #\=))
|
||||
(> byte 126))
|
||||
(out #\=)
|
||||
(out2hex byte)
|
||||
(f++ column 3))
|
||||
(t
|
||||
(out (code-char byte))
|
||||
(f++ column)))))
|
||||
(when (and line-length
|
||||
(>= column line-length))
|
||||
;; soft line break
|
||||
(outs #.(coerce '(#\= #\newline) 'string))
|
||||
(setf column 0)))))
|
||||
|
||||
(defmethod encoder-finish-output ((encoder quoted-printable-encoder))
|
||||
(declare (optimize (speed 3) (safety 0) (debug 0)))
|
||||
(with-slots (pending-space output-function) encoder
|
||||
(declare (type boolean pending-space)
|
||||
(type function output-function))
|
||||
(when pending-space
|
||||
(flet ((outs (s)
|
||||
(declare (type simple-string s))
|
||||
(loop
|
||||
for c across s
|
||||
do (funcall output-function c))))
|
||||
(setf pending-space nil)
|
||||
(outs "=20")))))
|
||||
|
||||
(defun encode-quoted-printable-stream (in out)
|
||||
"Read from IN a stream of bytes and write to OUT a stream of
|
||||
characters quoted printables encoded."
|
||||
(make-encoder-loop quoted-printable-encoder
|
||||
(read-byte in nil)
|
||||
(write-char char out)))
|
||||
|
||||
(defun encode-quoted-printable-sequence-to-stream (sequence stream &key (start 0) (end (length sequence)))
|
||||
"Encode the sequence of bytes SEQUENCE and write to STREAM a
|
||||
quoted printable sequence of characters."
|
||||
(be i start
|
||||
(make-encoder-loop quoted-printable-encoder
|
||||
(when (< i end)
|
||||
(prog1 (elt sequence i)
|
||||
(f++ i)))
|
||||
(write-char char stream))))
|
||||
|
||||
(defun encode-quoted-printable-sequence (sequence &key (start 0) (end (length sequence)))
|
||||
"Encode the sequence of bytes SEQUENCE into a quoted printable
|
||||
string and return it."
|
||||
(with-output-to-string (out)
|
||||
(encode-quoted-printable-sequence-to-stream sequence out :start start :end end)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defclass base64-encoder (line-encoder)
|
||||
((line-length :initform *base64-line-length*)
|
||||
(bitstore :initform 0
|
||||
:type fixnum)
|
||||
(bytecount :initform 0
|
||||
:type fixnum))
|
||||
(:documentation
|
||||
"Class for Base64 encoder output streams."))
|
||||
|
||||
|
||||
(eval-when (:load-toplevel :compile-toplevel)
|
||||
(unless (> most-positive-fixnum (expt 2 (* 8 3)))))
|
||||
|
||||
(macrolet ((with-encoder (encoder &body forms)
|
||||
`(with-slots (bitstore line-length column bytecount output-function) ,encoder
|
||||
(declare (type fixnum column)
|
||||
(type fixnum bitstore bytecount)
|
||||
(type (or fixnum null) line-length)
|
||||
(type function output-function))
|
||||
(labels ((emitr (i b)
|
||||
(declare (type fixnum i b))
|
||||
(unless (zerop i)
|
||||
(emitr (1- i) (ash b -6)))
|
||||
(emitc
|
||||
(char +base64-encode-table+ (logand b #x3F)))
|
||||
(values))
|
||||
(out (c)
|
||||
(funcall output-function c))
|
||||
(eol ()
|
||||
(progn
|
||||
(out #\return)
|
||||
(out #\newline)))
|
||||
(emitc (char)
|
||||
(out char)
|
||||
(f++ column)
|
||||
(when (and line-length
|
||||
(>= column line-length))
|
||||
(setf column 0)
|
||||
(eol))))
|
||||
(declare (inline out eol emitc)
|
||||
(ignorable (function emitr) (function out) (function eol) (function emitc)))
|
||||
,@forms))))
|
||||
;; For this function to work correctly, the FIXNUM must be at least
|
||||
;; 24 bits.
|
||||
(defmethod encoder-write-byte ((encoder base64-encoder) byte)
|
||||
(declare (optimize (speed 3) (safety 0) (debug 0))
|
||||
(type (unsigned-byte 8) byte))
|
||||
(with-encoder encoder
|
||||
(setf bitstore (logior byte (the fixnum (ash bitstore 8))))
|
||||
(f++ bytecount)
|
||||
(when (= 3 bytecount)
|
||||
(emitr 3 bitstore)
|
||||
(setf bitstore 0
|
||||
bytecount 0)))
|
||||
(values))
|
||||
|
||||
(defmethod encoder-finish-output ((encoder base64-encoder))
|
||||
(with-encoder encoder
|
||||
(unless (zerop bytecount)
|
||||
(multiple-value-bind (saved6 rest) (truncate (* bytecount 8) 6)
|
||||
(setf bitstore (ash bitstore (- 6 rest)))
|
||||
(emitr saved6 bitstore)
|
||||
(dotimes (x (- 3 saved6))
|
||||
(emitc #\=))))
|
||||
(when (and line-length
|
||||
(not (zerop column)))
|
||||
(eol)))
|
||||
(values)))
|
||||
|
||||
(defun encode-base64-stream (in out)
|
||||
"Read a byte stream from IN and write to OUT the encoded Base64
|
||||
character stream."
|
||||
(make-encoder-loop base64-encoder (read-byte in nil)
|
||||
(write-char char out)))
|
||||
|
||||
(defun encode-base64-sequence-to-stream (sequence stream &key (start 0) (end (length sequence)))
|
||||
"Encode the sequence of bytes SEQUENCE and write to STREAM the
|
||||
Base64 character sequence."
|
||||
(be i start
|
||||
(make-encoder-loop base64-encoder
|
||||
(when (< i end)
|
||||
(prog1 (elt sequence i)
|
||||
(incf i)))
|
||||
(write-char char stream))))
|
||||
|
||||
(defun encode-base64-sequence (sequence &key (start 0) (end (length sequence)))
|
||||
"Encode the sequence of bytes SEQUENCE into a Base64 string and
|
||||
return it."
|
||||
(with-output-to-string (out)
|
||||
(encode-base64-sequence-to-stream sequence out :start start :end end)))
|
||||
|
||||
(defclass base64-decoder (parsing-decoder)
|
||||
((bitstore :initform 0
|
||||
:type fixnum)
|
||||
(bytecount :initform 0 :type fixnum))
|
||||
(:documentation
|
||||
"Class for Base64 decoder input streams."))
|
||||
|
||||
(defmethod decoder-read-byte ((decoder base64-decoder))
|
||||
(declare (optimize (speed 3) (safety 0) (debug 0)))
|
||||
(with-slots (bitstore bytecount input-function) decoder
|
||||
(declare (type fixnum bitstore bytecount)
|
||||
(type function input-function))
|
||||
(labels ((in6 ()
|
||||
(loop
|
||||
for c = (funcall input-function)
|
||||
when (or (not c) (char= #\= c))
|
||||
do (return-from decoder-read-byte nil)
|
||||
do (be sextet (aref +base64-decode-table+ (char-code c))
|
||||
(unless (= sextet 65) ; ignore unrecognised characters
|
||||
(return sextet)))))
|
||||
(push6 (sextet)
|
||||
(declare (type fixnum sextet))
|
||||
(setf bitstore
|
||||
(logior sextet (the fixnum (ash bitstore 6))))))
|
||||
(case bytecount
|
||||
(0
|
||||
(setf bitstore (in6))
|
||||
(push6 (in6))
|
||||
(setf bytecount 1)
|
||||
(ash bitstore -4))
|
||||
(1
|
||||
(push6 (in6))
|
||||
(setf bytecount 2)
|
||||
(logand #xFF (ash bitstore -2)))
|
||||
(2
|
||||
(push6 (in6))
|
||||
(setf bytecount 0)
|
||||
(logand #xFF bitstore))))))
|
||||
|
||||
(defun decode-base64-stream (in out &key parser-errors)
|
||||
"Read from IN a stream of characters Base64 encoded and write
|
||||
to OUT a stream of decoded bytes."
|
||||
(make-decoder-loop base64-decoder
|
||||
(read-byte in nil) (write-byte byte out)
|
||||
:parser-errors parser-errors))
|
||||
|
||||
(defun decode-base64-stream-to-sequence (stream &key parser-errors)
|
||||
(make-stream-to-sequence-decoder base64-decoder
|
||||
(read-char stream nil)
|
||||
:parser-errors parser-errors))
|
||||
|
||||
(defun decode-base64-string (string &key (start 0) (end (length string)) parser-errors)
|
||||
(with-input-from-string (in string :start start :end end)
|
||||
(decode-base64-stream-to-sequence in :parser-errors parser-errors)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defun dump-stream-binary (in out)
|
||||
"Write content of IN character stream to OUT binary stream."
|
||||
(loop
|
||||
for c = (read-char in nil)
|
||||
while c
|
||||
do (write-byte (char-code c) out)))
|
||||
|
||||
(defun decode-stream (in out encoding &key parser-errors-p)
|
||||
(gcase (encoding string-equal)
|
||||
(:quoted-printable
|
||||
(decode-quoted-printable-stream in out
|
||||
:parser-errors parser-errors-p))
|
||||
(:base64
|
||||
(decode-base64-stream in out
|
||||
:parser-errors parser-errors-p))
|
||||
(otherwise
|
||||
(dump-stream-binary in out))))
|
||||
|
||||
(defun decode-string (string encoding &key parser-errors-p)
|
||||
(gcase (encoding string-equal)
|
||||
(:quoted-printable
|
||||
(decode-quoted-printable-string string
|
||||
:parser-errors parser-errors-p))
|
||||
(:base64
|
||||
(decode-base64-string string
|
||||
:parser-errors parser-errors-p))
|
||||
(otherwise
|
||||
(map '(vector (unsigned-byte 8)) #'char-code string))))
|
||||
|
||||
(defun decode-stream-to-sequence (stream encoding &key parser-errors-p)
|
||||
(gcase (encoding string-equal)
|
||||
(:quoted-printable
|
||||
(decode-quoted-printable-stream-to-sequence stream
|
||||
:parser-errors parser-errors-p))
|
||||
(:base64
|
||||
(decode-base64-stream-to-sequence stream
|
||||
:parser-errors parser-errors-p))
|
||||
(otherwise
|
||||
(loop
|
||||
with output-sequence = (make-array 0 :fill-pointer 0
|
||||
:element-type '(unsigned-byte 8)
|
||||
:adjustable t)
|
||||
for c = (read-char stream nil)
|
||||
while c
|
||||
do (vector-push-extend (char-code c) output-sequence)
|
||||
finally (return output-sequence)))))
|
||||
|
||||
(defun encode-stream (in out encoding)
|
||||
(gcase (encoding string-equal)
|
||||
(:quoted-printable
|
||||
(encode-quoted-printable-stream in out))
|
||||
(:base64
|
||||
(encode-base64-stream in out))
|
||||
(otherwise
|
||||
(loop
|
||||
for byte = (read-byte in nil)
|
||||
while byte
|
||||
do (write-char (code-char byte) out)))))
|
||||
|
||||
(defun encode-sequence-to-stream (sequence out encoding)
|
||||
(gcase (encoding string-equal)
|
||||
(:quoted-printable
|
||||
(encode-quoted-printable-sequence-to-stream sequence out))
|
||||
(:base64
|
||||
(encode-base64-sequence-to-stream sequence out))
|
||||
(otherwise
|
||||
(loop
|
||||
for byte across sequence
|
||||
do (write-char (code-char byte) out)))))
|
||||
|
||||
(defun encode-sequence (sequence encoding)
|
||||
(gcase (encoding string-equal)
|
||||
(:quoted-printable
|
||||
(encode-quoted-printable-sequence sequence))
|
||||
(:base64
|
||||
(encode-base64-sequence sequence))
|
||||
(otherwise
|
||||
(map 'string #'code-char sequence))))
|
||||
|
||||
;; This is similar to decode-quoted-printable-string but #\_ is used
|
||||
;; instead of space
|
||||
(defun decode-quoted-printable-RFC2047-string (string &key (start 0) (end (length string)))
|
||||
"Decode a string encoded according to the quoted printable
|
||||
method of RFC2047 and return a sequence of bytes."
|
||||
(declare (optimize (speed 3) (debug 0) (safety 0))
|
||||
(type simple-string string))
|
||||
(loop
|
||||
with output-sequence = (make-array (length string)
|
||||
:element-type '(unsigned-byte 8)
|
||||
:fill-pointer 0)
|
||||
for i fixnum from start by 1 below end
|
||||
for c = (char string i)
|
||||
do (case c
|
||||
(#\=
|
||||
(vector-push-extend (or (parse-hex (char string (1+ i)) (char string (+ 2 i)))
|
||||
;; the char code was malformed
|
||||
#.(char-code #\?))
|
||||
output-sequence)
|
||||
(f++ i 2))
|
||||
(#\_ (vector-push-extend #.(char-code #\space) output-sequence))
|
||||
(otherwise
|
||||
(vector-push-extend (char-code c) output-sequence)))
|
||||
finally (return output-sequence)))
|
||||
|
||||
(defun decode-RFC2047-string (encoding string &key (start 0) (end (length string)))
|
||||
"Decode STRING according to RFC2047 and return a sequence of
|
||||
bytes."
|
||||
(gcase (encoding string-equal)
|
||||
("Q" (decode-quoted-printable-RFC2047-string string :start start :end end))
|
||||
("B" (decode-base64-string string :start start :end end))
|
||||
(t string)))
|
||||
|
||||
(defun parse-RFC2047-text (text)
|
||||
"Parse the string TEXT according to RFC2047 rules and return a list
|
||||
of pairs and strings. The strings are the bits interposed between the
|
||||
actually encoded text. The pairs are composed of: a decoded byte
|
||||
sequence, a charset string indicating the original coding."
|
||||
(loop
|
||||
with result = '()
|
||||
with previous-end = 0
|
||||
for start = (search "=?" text :start2 previous-end)
|
||||
while start
|
||||
for first-? = (position #\? text :start (+ 2 start))
|
||||
while first-?
|
||||
for second-? = (position #\? text :start (1+ first-?))
|
||||
while second-?
|
||||
for end = (search "?=" text :start2 (1+ second-?))
|
||||
while end
|
||||
do (let ((charset (string-upcase (subseq text (+ 2 start) first-?)))
|
||||
(encoding (subseq text (1+ first-?) second-?)))
|
||||
(unless (= previous-end start)
|
||||
(push (subseq text previous-end start)
|
||||
result))
|
||||
(setf previous-end (+ end 2))
|
||||
(push (cons (decode-RFC2047-string encoding text :start (1+ second-?) :end end)
|
||||
charset)
|
||||
result))
|
||||
finally (unless (= previous-end (length text))
|
||||
(push (subseq text previous-end (length text))
|
||||
result))
|
||||
(return (nreverse result))))
|
||||
Loading…
Add table
Add a link
Reference in a new issue