8f6955176f
The following changes are required to make mime4cl build: * file-position doesn't like to be called with NIL as the position argument, so we have to make sure to not do that in stream-file-position. My workaround is a bit clunky, but works. * Tests discover the sample file via relative path resolution. This doesn't work when they are imported into the nix store as individual files. Instead we make use of the fact that DEFVAR is a no-op if the variable is already defined and inject a file via the nix build that sets the relevant ones. For the path to sample1.msg, we need to create a new variable. Change-Id: I74eeda7bf2c2a4f64cc2b90e72081513ec3285d5 Reviewed-on: https://cl.tvl.fyi/c/depot/+/3270 Tested-by: BuildkiteCI Reviewed-by: grfn <grfn@gws.fyi>
368 lines
13 KiB
Common Lisp
368 lines
13 KiB
Common Lisp
;;; eds.lisp --- En/De-coding Streams
|
|
|
|
;;; Copyright (C) 2012 by Walter C. Pelissero
|
|
;;; Copyright (C) 2021 by the TVL Authors
|
|
|
|
;;; Author: Walter C. Pelissero <walter@pelissero.de>
|
|
;;; Project: mime4cl
|
|
|
|
#+cmu (ext:file-comment "$Module: eds.lisp")
|
|
|
|
;;; 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)
|
|
|
|
#+cmu
|
|
(eval-when (:load-toplevel :compile-toplevel :execute)
|
|
;; CMUCL doesn't provide the STREAM-FILE-POSITION method in its
|
|
;; implementation of Gray streams. We patch it in ourselves.
|
|
(defgeneric stream-file-position (stream &optional position))
|
|
(defun my-file-position (stream &optional position)
|
|
(stream-file-position stream position))
|
|
(defvar *original-file-position-function*
|
|
(prog1
|
|
(symbol-function 'file-position)
|
|
(setf (symbol-function 'file-position) (symbol-function 'my-file-position))))
|
|
(defmethod stream-file-position (stream &optional position)
|
|
(if position
|
|
(funcall *original-file-position-function* stream position)
|
|
(funcall *original-file-position-function* stream)))
|
|
|
|
;; oddly CMUCL doesn't seem to provide a default for STREAM-READ-SEQUENCE
|
|
(defmacro make-read-sequence (stream-type element-reader)
|
|
`(defmethod stream-read-sequence ((stream ,stream-type) seq &optional start end)
|
|
(unless start
|
|
(setf start 0))
|
|
(unless end
|
|
(setf end (length seq)))
|
|
(loop
|
|
for i from start below end
|
|
for b = (,element-reader stream)
|
|
until (eq b :eof)
|
|
do (setf (elt seq i) b)
|
|
finally (return i))))
|
|
|
|
(make-read-sequence fundamental-binary-input-stream stream-read-byte)
|
|
(make-read-sequence fundamental-character-input-stream stream-read-char))
|
|
|
|
(defclass coder-stream-mixin ()
|
|
((real-stream :type stream
|
|
:initarg :stream
|
|
:reader real-stream)
|
|
(dont-close :initform nil
|
|
:initarg :dont-close)))
|
|
|
|
(defmethod stream-file-position ((stream coder-stream-mixin) &optional position)
|
|
(apply #'file-position (remove nil (list (slot-value stream 'real-stream)
|
|
position))))
|
|
|
|
(defclass coder-input-stream-mixin (fundamental-binary-input-stream coder-stream-mixin)
|
|
())
|
|
(defclass coder-output-stream-mixin (fundamental-binary-output-stream coder-stream-mixin)
|
|
())
|
|
|
|
|
|
(defclass quoted-printable-decoder-stream (coder-input-stream-mixin quoted-printable-decoder) ())
|
|
(defclass base64-decoder-stream (coder-input-stream-mixin base64-decoder) ())
|
|
(defclass 8bit-decoder-stream (coder-input-stream-mixin 8bit-decoder) ())
|
|
|
|
(defclass quoted-printable-encoder-stream (coder-output-stream-mixin quoted-printable-encoder) ())
|
|
(defclass base64-encoder-stream (coder-output-stream-mixin base64-encoder) ())
|
|
(defclass 8bit-encoder-stream (coder-output-stream-mixin 8bit-encoder) ())
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defmethod initialize-instance :after ((stream coder-stream-mixin) &key &allow-other-keys)
|
|
(unless (slot-boundp stream 'real-stream)
|
|
(error "REAL-STREAM is unbound. Must provide a :STREAM argument.")))
|
|
|
|
(defmethod initialize-instance ((stream coder-output-stream-mixin) &key &allow-other-keys)
|
|
(call-next-method)
|
|
(unless (slot-boundp stream 'output-function)
|
|
(setf (slot-value stream 'output-function)
|
|
#'(lambda (char)
|
|
(write-char char (slot-value stream 'real-stream))))))
|
|
|
|
(defmethod initialize-instance ((stream coder-input-stream-mixin) &key &allow-other-keys)
|
|
(call-next-method)
|
|
(unless (slot-boundp stream 'input-function)
|
|
(setf (slot-value stream 'input-function)
|
|
#'(lambda ()
|
|
(read-char (slot-value stream 'real-stream) nil)))))
|
|
|
|
(defmethod stream-read-byte ((stream coder-input-stream-mixin))
|
|
(or (decoder-read-byte stream)
|
|
:eof))
|
|
|
|
(defmethod stream-write-byte ((stream coder-output-stream-mixin) byte)
|
|
(encoder-write-byte stream byte))
|
|
|
|
(defmethod close ((stream coder-stream-mixin) &key abort)
|
|
(with-slots (real-stream dont-close) stream
|
|
(unless dont-close
|
|
(close real-stream :abort abort))))
|
|
|
|
(defmethod close ((stream coder-output-stream-mixin) &key abort)
|
|
(unless abort
|
|
(encoder-finish-output stream))
|
|
(call-next-method))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defclass encoder-input-stream (fundamental-character-input-stream coder-stream-mixin)
|
|
((encoder)
|
|
(buffer-queue :initform (make-queue)))
|
|
(:documentation
|
|
"This is the base class for encoders with the direction swapped. It
|
|
reads from REAL-STREAM a stream of bytes, encodes it and returnes it
|
|
in a stream of character."))
|
|
|
|
(defclass quoted-printable-encoder-input-stream (encoder-input-stream) ())
|
|
(defclass base64-encoder-input-stream (encoder-input-stream) ())
|
|
(defclass 8bit-encoder-input-stream (fundamental-character-input-stream coder-stream-mixin) ())
|
|
|
|
(defmethod initialize-instance ((stream quoted-printable-encoder-input-stream) &key &allow-other-keys)
|
|
(call-next-method)
|
|
(with-slots (encoder buffer-queue) stream
|
|
(setf encoder
|
|
(make-instance 'quoted-printable-encoder
|
|
:output-function #'(lambda (char)
|
|
(queue-append buffer-queue char))))))
|
|
|
|
(defmethod initialize-instance ((stream base64-encoder-input-stream) &key &allow-other-keys)
|
|
(call-next-method)
|
|
(with-slots (encoder buffer-queue) stream
|
|
(setf encoder
|
|
(make-instance 'base64-encoder
|
|
:output-function #'(lambda (char)
|
|
(queue-append buffer-queue char))))))
|
|
|
|
(defmethod stream-read-char ((stream encoder-input-stream))
|
|
(with-slots (encoder buffer-queue real-stream) stream
|
|
(loop
|
|
while (queue-empty-p buffer-queue)
|
|
do (be byte (read-byte real-stream nil)
|
|
(if byte
|
|
(encoder-write-byte encoder byte)
|
|
(progn
|
|
(encoder-finish-output encoder)
|
|
(queue-append buffer-queue :eof)))))
|
|
(queue-pop buffer-queue)))
|
|
|
|
|
|
(defmethod stream-read-char ((stream 8bit-encoder-input-stream))
|
|
(with-slots (real-stream) stream
|
|
(aif (read-byte real-stream nil)
|
|
(code-char it)
|
|
:eof)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defclass input-adapter-stream ()
|
|
((source :initarg :source)
|
|
(real-stream)
|
|
(input-function)))
|
|
|
|
(defclass binary-input-adapter-stream (fundamental-binary-input-stream input-adapter-stream) ())
|
|
|
|
(defclass character-input-adapter-stream (fundamental-character-input-stream input-adapter-stream) ())
|
|
|
|
(defmethod stream-element-type ((stream binary-input-adapter-stream))
|
|
'(unsigned-byte 8))
|
|
|
|
(defmethod initialize-instance ((stream input-adapter-stream) &key &allow-other-keys)
|
|
(call-next-method)
|
|
(assert (slot-boundp stream 'source)))
|
|
|
|
(defmethod initialize-instance ((stream binary-input-adapter-stream) &key &allow-other-keys)
|
|
(call-next-method)
|
|
;; REAL-STREAM slot is set only if we are going to close it later on
|
|
(with-slots (source real-stream input-function) stream
|
|
(etypecase source
|
|
(string
|
|
(setf real-stream (make-string-input-stream source)
|
|
input-function #'(lambda ()
|
|
(awhen (read-char real-stream nil)
|
|
(char-code it)))))
|
|
((vector (unsigned-byte 8))
|
|
(be i 0
|
|
(setf input-function #'(lambda ()
|
|
(when (< i (length source))
|
|
(prog1 (aref source i)
|
|
(incf i)))))))
|
|
(stream
|
|
(assert (input-stream-p source))
|
|
(setf input-function (if (subtypep (stream-element-type source) 'character)
|
|
#'(lambda ()
|
|
(awhen (read-char source nil)
|
|
(char-code it)))
|
|
#'(lambda ()
|
|
(read-byte source nil)))))
|
|
(pathname
|
|
(setf real-stream (open source :element-type '(unsigned-byte 8))
|
|
input-function #'(lambda ()
|
|
(read-byte real-stream nil))))
|
|
(file-portion
|
|
(setf real-stream (open-decoded-file-portion source)
|
|
input-function #'(lambda ()
|
|
(read-byte real-stream nil)))))))
|
|
|
|
(defmethod initialize-instance ((stream character-input-adapter-stream) &key &allow-other-keys)
|
|
(call-next-method)
|
|
;; REAL-STREAM slot is set only if we are going to close later on
|
|
(with-slots (source real-stream input-function) stream
|
|
(etypecase source
|
|
(string
|
|
(setf real-stream (make-string-input-stream source)
|
|
input-function #'(lambda ()
|
|
(read-char real-stream nil))))
|
|
((vector (unsigned-byte 8))
|
|
(be i 0
|
|
(setf input-function #'(lambda ()
|
|
(when (< i (length source))
|
|
(prog1 (code-char (aref source i))
|
|
(incf i)))))))
|
|
(stream
|
|
(assert (input-stream-p source))
|
|
(setf input-function (if (subtypep (stream-element-type source) 'character)
|
|
#'(lambda ()
|
|
(read-char source nil))
|
|
#'(lambda ()
|
|
(awhen (read-byte source nil)
|
|
(code-char it))))))
|
|
(pathname
|
|
(setf real-stream (open source :element-type 'character)
|
|
input-function #'(lambda ()
|
|
(read-char real-stream nil))))
|
|
(file-portion
|
|
(setf real-stream (open-decoded-file-portion source)
|
|
input-function #'(lambda ()
|
|
(awhen (read-byte real-stream nil)
|
|
(code-char it))))))))
|
|
|
|
(defmethod close ((stream input-adapter-stream) &key abort)
|
|
(when (slot-boundp stream 'real-stream)
|
|
(with-slots (real-stream) stream
|
|
(close real-stream :abort abort))))
|
|
|
|
(defmethod stream-read-byte ((stream binary-input-adapter-stream))
|
|
(with-slots (input-function) stream
|
|
(or (funcall input-function)
|
|
:eof)))
|
|
|
|
(defmethod stream-read-char ((stream character-input-adapter-stream))
|
|
(with-slots (input-function) stream
|
|
(or (funcall input-function)
|
|
:eof)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defclass delimited-input-stream (fundamental-character-input-stream coder-stream-mixin)
|
|
((start-offset :initarg :start
|
|
:initform 0
|
|
:reader stream-start
|
|
:type integer)
|
|
(end-offset :initarg :end
|
|
:initform nil
|
|
:reader stream-end
|
|
:type (or null integer))))
|
|
|
|
(defmethod print-object ((object delimited-input-stream) stream)
|
|
(if *print-readably*
|
|
(call-next-method)
|
|
(with-slots (start-offset end-offset) object
|
|
(print-unreadable-object (object stream :type t :identity t)
|
|
(format stream "start=~A end=~A" start-offset end-offset)))))
|
|
|
|
(defun base-stream (stream)
|
|
(if (typep stream 'delimited-input-stream)
|
|
(base-stream (real-stream stream))
|
|
stream))
|
|
|
|
(defmethod initialize-instance ((stream delimited-input-stream) &key &allow-other-keys)
|
|
(call-next-method)
|
|
(unless (slot-boundp stream 'real-stream)
|
|
(error "REAL-STREAM is unbound. Must provide a :STREAM argument."))
|
|
(with-slots (start-offset) stream
|
|
(when start-offset
|
|
(file-position stream start-offset))))
|
|
|
|
(defmethod stream-read-char ((stream delimited-input-stream))
|
|
(with-slots (real-stream end-offset) stream
|
|
(if (or (not end-offset)
|
|
(< (file-position real-stream) end-offset))
|
|
(or (read-char real-stream nil)
|
|
:eof)
|
|
:eof)))
|
|
|
|
#+(OR)(defmethod stream-read-byte ((stream delimited-input-stream))
|
|
(with-slots (real-stream end-offset) stream
|
|
(if (or (not end-offset)
|
|
(< (file-position real-stream) end-offset))
|
|
(or (read-byte real-stream nil)
|
|
:eof)
|
|
:eof)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defclass my-string-input-stream (fundamental-character-input-stream coder-stream-mixin)
|
|
((string :initarg :string
|
|
:reader stream-string)))
|
|
|
|
(defmethod initialize-instance ((stream my-string-input-stream) &key &allow-other-keys)
|
|
(call-next-method)
|
|
(assert (slot-boundp stream 'string))
|
|
(with-slots (string real-stream) stream
|
|
(setf real-stream (make-string-input-stream string))))
|
|
|
|
(defmethod stream-read-char ((stream my-string-input-stream))
|
|
(with-slots (real-stream) stream
|
|
(or (read-char real-stream nil)
|
|
:eof)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defstruct file-portion
|
|
data ; string or a pathname
|
|
encoding
|
|
start
|
|
end)
|
|
|
|
(defun open-file-portion (file-portion)
|
|
(be data (file-portion-data file-portion)
|
|
(etypecase data
|
|
(pathname
|
|
(be stream (open data)
|
|
(make-instance 'delimited-input-stream
|
|
:stream stream
|
|
:start (file-portion-start file-portion)
|
|
:end (file-portion-end file-portion))))
|
|
(string
|
|
(make-instance 'delimited-input-stream
|
|
:stream (make-string-input-stream data)
|
|
:start (file-portion-start file-portion)
|
|
:end (file-portion-end file-portion)))
|
|
(stream
|
|
(make-instance 'delimited-input-stream
|
|
:stream data
|
|
:dont-close t
|
|
:start (file-portion-start file-portion)
|
|
:end (file-portion-end file-portion))))))
|
|
|
|
(defun open-decoded-file-portion (file-portion)
|
|
(make-instance (case (file-portion-encoding file-portion)
|
|
(:quoted-printable 'quoted-printable-decoder-stream)
|
|
(:base64 'base64-decoder-stream)
|
|
(t '8bit-decoder-stream))
|
|
:stream (open-file-portion file-portion)))
|