;; -*- Mode: Lisp; -*- ;; --------------------------------------------------------------------------- ;; Title: READ-SEQUENCE* - An enhanced READ-SEQUENCE ;; Created: 2024-11-11 ;; Author: Gilbert Baumann ;; License: MIT style (see below) ;; --------------------------------------------------------------------------- ;; (c) copyright 2024 by Gilbert Baumann ;; Permission is hereby granted, free of charge, to any person obtaining ;; a copy of this software and associated documentation files (the ;; "Software"), to deal in the Software without restriction, including ;; without limitation the rights to use, copy, modify, merge, publish, ;; distribute, sublicense, and/or sell copies of the Software, and to ;; permit persons to whom the Software is furnished to do so, subject to ;; the following conditions: ;; ;; The above copyright notice and this permission notice shall be ;; included in all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. (defpackage :read-sequence-star (:use :cl) (:export #:read-sequence* #:read-byte-no-hang #:stream-read-sequence* #:stream-buffered-bytes-count #:stream-buffered-chars-count #:stream-read-char* #:stream-read-byte* ;; Not implement, but reserved #:write-sequence* #:stream-write-sequence* #:stream-input-would-block-p #:stream-output-would-block-p #:input-would-block-p #:output-would-block-p #:wait-for-input-available #:wait-for-output-possible)) (in-package :read-sequence-star) ;;;; -- Implementation Notes ------------------------------------------------------------------ ;; The most portable approach is STREAM-BUFFERED-BYTES-COUNT and ;; STREAM-BUFFERED-CHARS-COUNT. The idea is that we can indeed look at the ;; internal stream buffer. Given that we can implement the block-at-most-once ;; behavior of READ-SEQUENCE* by first do a blocking regulare READ-CHAR or ;; READ-BYTE and then copy the amount buffered. ;; In conforming ANSI-CL we can have the full functionality only for character ;; streams, when we poll using READ-CHAR-NO-HANG. ;; For binary streams, we're out of luck. There is no READ-BYTE-NO-HANG and ;; LISTEN on end of file would return NIL. So we're out of luck there. ;;;; ------------------------------------------------------------------------------------------ (defgeneric stream-buffered-bytes-count (stream) (:documentation "Returns an estimate and bound of the number of the buffered bytes of /stream/. The only guarantee is that reading that many bytes from the stream /stream/ will turn to the stream buffer without any further system call or input/output operation.")) (defgeneric stream-buffered-chars-count (stream) (:documentation "Returns an estimate and bound of the number of the buffered characters of /stream/. The only guarantee is that reading that many characters from the stream /stream/ will turn to the stream buffer without any further system call or input/output operation.")) (defconstant +1/hz+ (coerce 1/1000 'single-float)) (defun read-byte-no-hang (stream &optional (eof-error t) eof-value) (read-byte* stream eof-error eof-value :timeout 0)) #+CCL (defun read-byte* (stream &optional eof-error eof-value &key (timeout nil timeout-p)) (cond ((not timeout-p) (read-byte stream eof-error eof-value)) (t (handler-bind ((ccl:input-timeout (lambda (c) (if (eq stream (stream-error-stream c)) (return-from read-byte* nil) (error c))))) (ccl:with-input-timeout ((stream) timeout) (read-byte stream eof-error eof-value)))))) #+CCL (defun read-char* (stream &optional eof-error eof-value &key (timeout nil timeout-p)) (cond ((not timeout-p) (read-char stream eof-error eof-value)) (t (handler-bind ((ccl:input-timeout (lambda (c) (if (eq stream (stream-error-stream c)) (return-from read-char* nil) (error c))))) (ccl:with-input-timeout ((stream) timeout) (read-char stream eof-error eof-value)))))) #-CCL (defun read-char* (stream &optional eof-error eof-value &key timeout) #+SBCL (declare (sb-ext:muffle-conditions sb-kernel:&optional-and-&key-in-lambda-list)) (cond ((null timeout) (read-char stream eof-error eof-value)) ((<= timeout 0) (read-char-no-hang stream eof-error eof-value)) (t (let ((dead-line (+ (get-internal-real-time) (ceiling (* internal-time-units-per-second timeout))))) (loop (let ((c (read-char-no-hang stream eof-error ':eof))) (cond ((eq c ':eof) (return eof-value)) ((not (null c)) (return c))) (sleep +1/hz+) (when (>= (get-internal-real-time) dead-line) (return nil)))))))) #+SBCL (defun read-byte* (stream &optional eof-error eof-value &key timeout) (cond ((null timeout) (read-byte stream eof-error eof-value)) (t ;; override? (handler-bind ((sb-sys:deadline-timeout (lambda (c) (declare (ignore c)) (return-from read-byte* nil)))) (sb-sys:with-deadline (:seconds timeout) (read-byte stream nil ':eof)))))) (defmethod stream-buffered-bytes-count ((stream t)) "The fallback." 0) (defmethod stream-buffered-chars-count ((stream t)) "The fallback." 0) #+CCL (progn (defmethod stream-buffered-bytes-count ((stream ccl::basic-binary-stream)) ;; For CCL we can only really tell with binary streams as the buffer is ;; kept as undecoded octets to allow for switching the external-format ;; on the fly. ;; ;; One may be tempted to say that /n/ octets yield at least /n/ ;; characters. But this isn't true. For one thing CRLF (two octets) ;; yields one character. For the other there might only be a part of a ;; multi-byte character. ;; ;; ### This is only true for (UNSIGNED-BYTE 8) (let ((ioblock (ccl::basic-stream-ioblock stream))) (ccl::with-ioblock-input-locked (ioblock) (let* ((buf (ccl::ioblock-inbuf ioblock))) (- (the fixnum (ccl::io-buffer-count buf)) (the fixnum (ccl::io-buffer-idx buf))))))) ) #+SBCL (progn ;; This IN-BUFFER keeps already decoded stream elements. Good for us. ;; But in general bad as this makes switching the external format ;; impossible. ;; ;; Further, this is only half the truth, FD streams have a second buffer ;; with (sb-impl::fd-stream-ibuf stream) and may not even have this ;; first buffer. ;; ;; On top of all that character input streams have this INSTEAD slot ;; which is a buffer prepended to the above. ;; ;; Still this is good as returning zero is a valid implementation. ;; (defmethod stream-buffered-bytes-count ((stream sb-impl::ansi-stream)) (- sb-impl::+ansi-stream-in-buffer-length+ (sb-impl::ansi-stream-in-index stream))) (defmethod stream-buffered-bytes-count ((stream sb-sys:fd-stream)) (let (ibuf) (+ (- sb-impl::+ansi-stream-in-buffer-length+ (sb-impl::ansi-stream-in-index stream)) (if (and (member (sb-impl::fd-stream-element-mode stream) '(unsigned-byte signed-byte)) (setq ibuf (sb-impl::fd-stream-ibuf stream))) (floor (- (sb-impl::buffer-tail ibuf) (sb-impl::buffer-head ibuf)) (sb-impl::fd-stream-element-size stream)) 0))) ) (defmethod stream-buffered-chars-count ((stream sb-impl::ansi-stream)) ;; This INSTEAD slot? (- sb-impl::+ansi-stream-in-buffer-length+ (sb-impl::ansi-stream-in-index stream)))) (defun read-sequence* (sequence stream &key (start 0) (end nil) (timeout nil) (short nil)) (check-type sequence sequence) (check-type stream stream) (check-type timeout (or null (real 0 *))) (let* ((len (length sequence)) (end (or end len))) (check-type start unsigned-byte) (check-type end unsigned-byte) (unless (<= 0 start end len) (error "~@" ':start start ':end end len)) (let* ((format (cond ((and (vectorp sequence) (subtypep (array-element-type sequence) 'integer)) :binary) ((and (vectorp sequence) (subtypep (array-element-type sequence) 'character)) :text) ((subtypep (stream-element-type stream) 'character) :text) ((subtypep (stream-element-type stream) 'integer) :binary) (t (error "~@"))))) (let ((dead-line (and timeout (+ (get-internal-real-time) (ceiling (* internal-time-units-per-second timeout))))) (ptr start)) ;; (loop (when (= ptr end) (return (values ptr nil))) (let ((avail (if (eq ':text format) (stream-buffered-chars-count stream) (stream-buffered-bytes-count stream)))) (cond ((> avail 0) ;; We win (let ((new-ptr (read-sequence sequence stream :start ptr :end (min end (+ ptr avail))))) (cond ((= ptr new-ptr) (return (values ptr ':eof))) (t (setq ptr new-ptr) (when short ;; This is questionable business. Depends a bit on whether we actually ;; have READ-READ-BYTE-NO-HANG. ;; ;; When asked for a short read, we're done. No need to call into ;; READ-CHAR* again. Which depending on the actual implementation might ;; involve further system calls, even with :TIMEOUT being zero. (return (values ptr nil))))))) (t (let ((c (funcall (if (eq :text format) #'read-char* #'read-byte*) stream nil ':eof :timeout (cond ((and (/= ptr start) short) 0) (dead-line (max 0 (/ (- dead-line (get-internal-real-time)) internal-time-units-per-second))) (t nil))))) (cond ((eq c ':eof) (return (values ptr ':eof))) ((null c) (return (values ptr (and (= ptr start) ':timeout)))) (t (setf (elt sequence ptr) c) (incf ptr)))))))))))) ;; SBCL: N-BIN _is_ the short read. ;;SB-IMPL::STREAM-ELEMENT-MODE ;;SB-IMPL::STREAM-ELEMENT-TYPE-STREAM-ELEMENT-MODE ;;;; -- Gray Stream Extensions ---------------------------------------------------------------- (defgeneric stream-read-byte-with-timeout (stream timeout)) (defgeneric stream-read-char-with-timeout (stream timeout))