about summary refs log tree commit diff
path: root/third_party/lisp/mime4cl/streams.lisp
diff options
context:
space:
mode:
Diffstat (limited to 'third_party/lisp/mime4cl/streams.lisp')
-rw-r--r--third_party/lisp/mime4cl/streams.lisp368
1 files changed, 368 insertions, 0 deletions
diff --git a/third_party/lisp/mime4cl/streams.lisp b/third_party/lisp/mime4cl/streams.lisp
new file mode 100644
index 000000000000..64c7adeec571
--- /dev/null
+++ b/third_party/lisp/mime4cl/streams.lisp
@@ -0,0 +1,368 @@
+ ;;; 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)))