;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*- ;;; $Header: /usr/local/cvsrep/flexi-streams/output.lisp,v 1.60 2008/05/21 01:26:43 edi Exp $ ;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved. ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package :flexi-streams) (defgeneric write-byte* (byte stream) (declare #.*standard-optimize-settings*) (:documentation "Writes one byte \(octet) to the underlying stream STREAM.")) #-:lispworks (defmethod write-byte* (byte (flexi-output-stream flexi-output-stream)) (declare #.*standard-optimize-settings*) (with-accessors ((stream flexi-stream-stream)) flexi-output-stream (write-byte byte stream))) #+:lispworks (defmethod write-byte* (byte (flexi-output-stream flexi-output-stream)) (declare #.*standard-optimize-settings*) ;; we use WRITE-SEQUENCE because WRITE-BYTE doesn't work with all ;; bivalent streams in LispWorks (4.4.6) (with-accessors ((stream flexi-stream-stream)) flexi-output-stream (write-sequence (make-array 1 :element-type 'octet :initial-element byte) stream) byte)) #+:lispworks (defmethod write-byte* (byte (flexi-output-stream flexi-binary-output-stream)) "Optimized version \(only needed for LispWorks) in case the underlying stream is binary." (declare #.*standard-optimize-settings*) (with-accessors ((stream flexi-stream-stream)) flexi-output-stream (write-byte byte stream))) (defmethod stream-write-char ((stream flexi-output-stream) char) (declare #.*standard-optimize-settings*) (with-accessors ((external-format flexi-stream-external-format)) stream (flet ((writer (octet) (write-byte* octet stream))) (declare (dynamic-extent (function writer))) (char-to-octets external-format char #'writer)))) (defmethod stream-write-char :after ((stream flexi-output-stream) char) (declare #.*standard-optimize-settings*) ;; update the column unless we're in the middle of the line and ;; the current value is NIL (with-accessors ((column flexi-stream-column)) stream (cond ((char= char #\Newline) (setq column 0)) (column (incf (the integer column)))))) (defmethod stream-clear-output ((flexi-output-stream flexi-output-stream)) "Simply calls the corresponding method for the underlying output stream." (declare #.*standard-optimize-settings*) (with-accessors ((stream flexi-stream-stream)) flexi-output-stream (clear-output stream))) (defmethod stream-finish-output ((flexi-output-stream flexi-output-stream)) "Simply calls the corresponding method for the underlying output stream." (declare #.*standard-optimize-settings*) (with-accessors ((stream flexi-stream-stream)) flexi-output-stream (finish-output stream))) (defmethod stream-force-output ((flexi-output-stream flexi-output-stream)) "Simply calls the corresponding method for the underlying output stream." (declare #.*standard-optimize-settings*) (with-accessors ((stream flexi-stream-stream)) flexi-output-stream (force-output stream))) (defmethod stream-line-column ((flexi-output-stream flexi-output-stream)) "Returns the column stored in the COLUMN slot of the FLEXI-OUTPUT-STREAM object STREAM." (declare #.*standard-optimize-settings*) (with-accessors ((column flexi-stream-column)) flexi-output-stream column)) (defmethod stream-write-byte ((flexi-output-stream flexi-output-stream) byte) "Writes a byte \(octet) to the underlying stream." (declare #.*standard-optimize-settings*) (with-accessors ((column flexi-stream-column)) flexi-output-stream ;; set column to NIL because we don't know how to handle binary ;; output mixed with character output (setq column nil) (write-byte* byte flexi-output-stream))) #+:allegro (defmethod stream-terpri ((stream flexi-output-stream)) "Writes a #\Newline character to the underlying stream." (declare #.*standard-optimize-settings*) ;; needed for AllegroCL - grrr... (stream-write-char stream #\Newline)) (defmethod stream-write-sequence ((stream flexi-output-stream) sequence start end &key) "An optimized version which uses a buffer underneath. The function can accepts characters as well as octets and it decides what to do based on the element type of the sequence \(if possible) or on the individual elements, i.e. you can mix characters and octets in SEQUENCE if you want. Whether that really works might also depend on your Lisp, some of the implementations are more picky than others." (declare #.*standard-optimize-settings*) (declare (fixnum start end)) (with-accessors ((column flexi-stream-column) (external-format flexi-stream-external-format) (stream flexi-stream-stream)) stream (let* ((octet-seen-p nil) (buffer-pos 0) ;; whether we might receive characters and thus the number ;; of octets to output might not be equal to the number of ;; sequence elements to write (chars-p (or (listp sequence) (and (vectorp sequence) (not (subtypep (array-element-type sequence) 'integer))))) (factor (if chars-p (encoding-factor external-format) 1)) (buffer-size (min +buffer-size+ (ceiling (* factor (- end start))))) (buffer (make-octet-buffer buffer-size))) (declare (fixnum buffer-pos buffer-size) (boolean octet-seen-p) (type (array octet *) buffer)) (labels ((flush-buffer () "Sends all octets in BUFFER to the underlying stream." (write-sequence buffer stream :end buffer-pos) (setq buffer-pos 0)) (write-octet (octet) "Adds one octet to the buffer and flush it if necessary." (declare (octet octet)) (when (>= buffer-pos buffer-size) (flush-buffer)) (setf (aref buffer buffer-pos) octet) (incf buffer-pos)) (write-character (char) "Adds the octets representing the character CHAR to the buffer." (char-to-octets external-format char #'write-octet)) (write-object (object) "Dispatches to WRITE-OCTET or WRITE-CHARACTER depending on the type of OBJECT." (etypecase object (octet (setq octet-seen-p t) (write-octet object)) (character (write-character object))))) (declare (dynamic-extent (function write-octet))) (macrolet ((iterate (octets-p output-form) "An unhygienic macro to implement the actual iteration through SEQUENCE. OUTPUT-FORM is the form to retrieve one sequence element and put its octet representation into the buffer. OCTETS-P is true if we know in advance that we will send octets." `(progn ,@(if octets-p '((setq octet-seen-p t))) (loop for index of-type fixnum from start below end do ,output-form finally (when (plusp buffer-pos) (flush-buffer)))))) (etypecase sequence (string (iterate nil (write-character (char sequence index)))) (array (let ((array-element-type (array-element-type sequence))) (cond ((type-equal array-element-type 'octet) (iterate t (write-octet (aref (the (array octet *) sequence) index)))) ((subtypep array-element-type 'integer) (iterate t (write-octet (aref sequence index)))) (t (iterate nil (write-object (aref sequence index))))))) (list (iterate nil (write-object (nth index sequence))))) ;; update the column slot, setting if to NIL if we sent octets (setq column (cond (octet-seen-p nil) (t (let ((last-newline-pos (position #\Newline sequence :test #'char= :start start :end end :from-end t))) (cond (last-newline-pos (- end last-newline-pos 1)) (column (+ column (- end start)))))))))))) sequence) (defmethod stream-write-string ((stream flexi-output-stream) string &optional (start 0) (end (length string))) "Simply hands over to the optimized method for STREAM-WRITE-SEQUENCE." (declare #.*standard-optimize-settings*) (stream-write-sequence stream string start (or end (length string))))