;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE: filter-stream.lisp
;;;;LANGUAGE: Common-Lisp
;;;;SYSTEM: Common-Lisp
;;;;USER-INTERFACE: NONE
;;;;DESCRIPTION
;;;;
;;;; Filter streams are stream wrappers with a function to process
;;;; the data being input or output.
;;;;
;;;;AUTHORS
;;;; <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;; 2017-04-16 <PJB> Close is also defered to the filter function.
;;;; Now all operations can be performed by the filter
;;;; function and the filter-stream stream can be any
;;;; object, not necessarily a stream.
;;;; 2016-12-22 <PJB> Created.
;;;;BUGS
;;;;LEGAL
;;;; AGPL3
;;;;
;;;; Copyright Pascal J. Bourguignon 2016 - 2016
;;;;
;;;; This program is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU Affero General Public License as published by
;;;; the Free Software Foundation, either version 3 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program 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 Affero General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Affero General Public License
;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;;;**************************************************************************
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf *readtable* (copy-readtable nil)))
(defpackage "COM.INFORMATIMAGO.CLEXT.FILTER-STREAM"
(:use "COMMON-LISP"
"TRIVIAL-GRAY-STREAMS")
(:export "MAKE-INPUT-FILTER-STREAM"
"MAKE-OUTPUT-FILTER-STREAM"
"FILTER-STREAM-STREAM"
"FILTER-STREAM-FUNCTION"
"FILTER-ELEMENT-TYPE"
"NO-FILTER"))
(in-package "COM.INFORMATIMAGO.CLEXT.FILTER-STREAM")
(defclass filter ()
((function :initarg :function :accessor filter-stream-function)
(stream :initarg :stream :accessor filter-stream-stream)
(element-type :initarg :element-type :reader filter-stream-element-type)))
(defclass filter-character-input-stream (filter fundamental-character-input-stream)
((column :initform 0 :accessor column)))
(defclass filter-character-output-stream (filter fundamental-character-output-stream)
((column :initform 0 :accessor column)))
(defclass filter-binary-input-stream (filter fundamental-binary-input-stream)
())
(defclass filter-binary-output-stream (filter fundamental-binary-output-stream)
())
(defun make-input-filter-stream (stream filter-function &key element-type)
(let ((element-type (or element-type (stream-element-type stream))))
(make-instance (if (subtypep element-type 'character)
'filter-character-input-stream
'filter-binary-input-stream)
:function filter-function
:stream stream)))
(defun make-output-filter-stream (stream filter-function &key element-type)
(let ((element-type (or element-type (stream-element-type stream))))
(make-instance (if (subtypep element-type 'character)
'filter-character-output-stream
'filter-binary-output-stream)
:function filter-function
:stream stream)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; stream methods
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun check-stream-open (stream where)
(unless (open-stream-p stream)
(error "~S cannot deal with closed stream ~S"
where stream)))
;;; character input
(declaim (inline update-column))
(defun update-column (stream ch)
(when (characterp ch)
(if (char= ch #\newline)
(setf (column stream) 0)
(incf (column stream))))
ch)
(defmethod stream-read-char ((stream filter-character-input-stream))
(check-stream-open stream 'stream-read-char)
(funcall (filter-stream-function stream)
'read-char
(filter-stream-stream stream)))
(defmethod stream-read-char-no-hang ((stream filter-character-input-stream))
(check-stream-open stream 'stream-read-char-no-hang)
(funcall (filter-stream-function stream)
'read-char-no-hang
(filter-stream-stream stream)))
(defmethod stream-peek-char ((stream filter-character-input-stream))
(check-stream-open stream 'stream-peek-char)
(funcall (filter-stream-function stream)
'peek-char
(filter-stream-stream stream)))
(defmethod stream-read-line ((stream filter-character-input-stream))
(check-stream-open stream 'stream-read-line)
(funcall (filter-stream-function stream)
'read-line
(filter-stream-stream stream)))
(defmethod stream-listen ((stream filter-character-input-stream))
(check-stream-open stream 'stream-listen)
(funcall (filter-stream-function stream)
'listen
(filter-stream-stream stream)))
(defmethod stream-unread-char ((stream filter-character-input-stream) ch)
(check-stream-open stream 'stream-unread-char)
(funcall (filter-stream-function stream)
'unread-char
(filter-stream-stream stream)
ch)
ch)
;;; character output
(defmethod stream-write-char ((stream filter-character-output-stream) ch)
(check-stream-open stream 'stream-write-char)
(funcall (filter-stream-function stream)
'write-char
(filter-stream-stream stream)
ch)
(if (char= #\newline ch)
(setf (column stream) 0)
(incf (column stream)))
ch)
(defmethod stream-terpri ((stream filter-character-output-stream))
(check-stream-open stream 'stream-terpri)
(stream-write-char stream #\newline)
nil)
(defmethod stream-write-string ((stream filter-character-output-stream) string &optional (start 0) end)
(check-stream-open stream 'stream-write-string)
(let* ((end (or end (length string)))
(nlp (position #\newline string :start start :end end :from-end t)))
(funcall (filter-stream-function stream)
'write-string
(filter-stream-stream stream)
string start (or end (length string)))
(if nlp
(setf (column stream) (- end nlp))
(incf (column stream) (- end start))))
string)
(defmethod stream-line-column ((stream filter-character-output-stream))
(column stream))
(defmethod stream-start-line-p ((stream filter-character-output-stream))
(zerop (column stream)))
(defmethod stream-advance-to-column ((stream filter-character-output-stream) column)
(check-stream-open stream 'stream-advance-to-column)
(let ((delta (- column (column stream))))
(when (plusp delta)
(stream-write-string stream (make-string delta :initial-element #\space))
delta)))
(defmethod close ((stream filter-character-output-stream) &key abort)
(funcall (filter-stream-function stream)
'close
(filter-stream-stream stream)
abort))
(defmethod close ((stream filter-binary-output-stream) &key abort)
(funcall (filter-stream-function stream)
'close
(filter-stream-stream stream)
abort))
(defmethod close ((stream filter-character-input-stream) &key abort)
(funcall (filter-stream-function stream)
'close
(filter-stream-stream stream)
abort))
(defmethod close ((stream filter-binary-input-stream) &key abort)
(funcall (filter-stream-function stream)
'close
(filter-stream-stream stream)
abort))
;; binary input
(defmethod stream-read-byte ((stream filter-binary-input-stream))
(check-stream-open stream 'stream-read-byte)
(funcall (filter-stream-function stream)
'read-byte
(filter-stream-stream stream)))
;; binary output
(defmethod stream-write-byte ((stream filter-binary-output-stream) byte)
(check-stream-open stream 'stream-write-byte)
(funcall (filter-stream-function stream)
'write-byte
(filter-stream-stream stream)
byte)
byte)
;;; sequence I/O
(defun check-sequence-arguments (direction stream sequence start end)
(assert (<= 0 start end (length sequence))
(sequence start end)
"START = ~D or END = ~D are not sequence bounding indexes for a ~S of length ~D"
start end (type-of sequence) (length sequence))
(ecase direction
(:read
(assert (or (listp sequence)
(and (vectorp sequence)
(subtypep (filter-stream-element-type stream) (array-element-type sequence))))
(sequence)
"For reading, the sequence element type ~S should be a supertype of the stream element type ~S"
(array-element-type sequence) (filter-stream-element-type stream)))
(:write
(assert (or (listp sequence)
(and (vectorp sequence)
(subtypep (array-element-type sequence) (filter-stream-element-type stream))))
(sequence)
"For writing, the sequence element type ~S should be a subtype of the stream element type ~S"
(array-element-type sequence) (filter-stream-element-type stream)))))
(defun %stream-read-sequence (stream sequence start end)
(check-sequence-arguments :read stream sequence start end)
(funcall (filter-stream-function stream)
'read-sequence
(filter-stream-stream stream)
sequence start end))
(defun %stream-write-sequence (stream sequence start end)
(check-sequence-arguments :write stream sequence start end)
(funcall (filter-stream-function stream)
'write-sequence
(filter-stream-stream stream)
sequence start end)
sequence)
(defmethod stream-read-sequence ((stream filter-character-input-stream) sequence start end &key &allow-other-keys)
(check-stream-open stream 'stream-read-sequence)
(%stream-read-sequence stream sequence start end))
(defmethod stream-read-sequence ((stream filter-binary-input-stream) sequence start end &key &allow-other-keys)
(check-stream-open stream 'stream-read-sequence)
(%stream-read-sequence stream sequence start end))
(defmethod stream-write-sequence ((stream filter-character-output-stream) sequence start end &key &allow-other-keys)
(check-stream-open stream 'stream-write-sequence)
(%stream-write-sequence stream sequence start end))
(defmethod stream-write-sequence ((stream filter-binary-output-stream) sequence start end &key &allow-other-keys)
(check-stream-open stream 'stream-write-sequence)
(%stream-write-sequence stream sequence start end))
(defun no-filter (operation stream &rest arguments)
(ecase operation
;; character
(read-char (read-char stream nil :eof))
(read-char-no-hang (read-char-no-hang stream nil :eof))
(peek-char (peek-char nil stream nil :eof))
(read-line (read-line stream nil :eof))
(listen (listen stream))
(unread-char (unread-char (first arguments) stream))
(write-char (write-char (first arguments) stream))
(write-string (write-string (first arguments) stream :start (second arguments) :end (third arguments)))
;; binary:
(read-byte (read-byte stream nil :eof))
(write-byte (write-byte (first arguments) stream))
;; both:
(read-sequence (read-sequence (first arguments) stream :start (second arguments) :end (third arguments)))
(write-sequence (write-sequence (first arguments) stream :start (second arguments) :end (third arguments)))
(close (close stream :abort (first arguments)))))
;;;; THE END ;;;;