Changeset 8486


Ignore:
Timestamp:
Feb 14, 2008, 9:08:16 AM (12 years ago)
Author:
gb
Message:

Get and set input/output timeouts for streams.
Changes to ioblock may be a little tricky to bootstrap.
Change return values of PROCESS-INPUT-WAIT and PROCESS-OUTPUT-WAIT;
optional second argument is now expressed in milliseconds.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-streams.lisp

    r8398 r8486  
    5858    :io
    5959    :output))
     60
     61(defun check-io-timeout (timeout)
     62  (when timeout
     63    (require-type timeout '(real 0 1000000))))
     64
     65(defmethod stream-input-timeout ((s input-stream))
     66  nil)
     67
     68(defmethod (setf input-stream-timeout) (new (s input-stream))
     69  (check-io-timeout new))
     70
     71(defmethod stream-output-timeout ((s output-stream))
     72  nil)
     73
     74(defmethod (setf stream-output-timeout) (new (s output-stream))
     75  (check-io-timeout new))
    6076
    6177;;; Try to return a string containing characters that're near the
     
    420436  (unread-char-function 'ioblock-no-char-input)
    421437  (encode-literal-char-code-limit 256)
    422   (reserved3 nil))
     438  (input-timeout nil)
     439  (output-timeout nil))
    423440
    424441
     
    37763793           (synonym-method stream-direction)
    37773794           (synonym-method stream-device direction)
    3778            (synonym-method stream-surrounding-characters))
     3795           (synonym-method stream-surrounding-characters)
     3796           (synonym-method stream-input-timeout)
     3797           (synonym-method stream-output-timeout))
     3798
     3799(defmethod (setf input-stream-timeout) (new (s synonym-stream))
     3800  (setf (input-stream-timeout (symbol-value (synonym-stream-symbol s))) new))
     3801
     3802(defmethod (setf output-stream-timeout) (new (s synonym-stream))
     3803  (setf (output-stream-timeout (symbol-value (synonym-stream-symbol s))) new))
    37793804
    37803805
     
    38363861  (two-way-input-method stream-read-vector v start end)
    38373862  (two-way-input-method stream-surrounding-characters)
     3863  (two-way-input-method stream-input-timeout)
    38383864  (two-way-output-method stream-write-char c)
    38393865  (two-way-output-method stream-write-byte b)
     
    38483874  (two-way-output-method stream-finish-output)
    38493875  (two-way-output-method stream-write-list l c)
    3850   (two-way-output-method stream-write-vector v start end))
     3876  (two-way-output-method stream-write-vector v start end)
     3877  (two-way-output-method stream-output-timeout))
     3878
     3879(defmethod (setf stream-input-timeout) (new (s two-way-stream))
     3880  (setf (stream-input-timeout (two-way-stream-input-stream s)) new))
     3881
     3882(defmethod (setf stream-output-timeout) (new (s two-way-stream))
     3883  (setf (stream-output-timeout (two-way-stream-output-stream s)) new))
    38513884
    38523885(defmethod stream-device ((s two-way-stream) direction)
     
    52105243  (rlet ((now :timeval))
    52115244    (let* ((wait-end
    5212             (if timeout
    5213               (multiple-value-bind (seconds millis) (milliseconds timeout)
    5214                 (#_gettimeofday now (%null-ptr))
    5215                 (setq timeout (+ (* seconds 1000) millis))
    5216                 (+ (timeval->milliseconds now) timeout)))))
     5245            (when timeout
     5246              (#_gettimeofday now (%null-ptr))
     5247              (+ (timeval->milliseconds now) timeout))))
    52175248      (loop
    5218         ;; FD-INPUT-AVAILABLE-P can return NIL (e.g., if the
    5219         ;; thread receives an interrupt) before a timeout is
    5220         ;; reached.
    5221         (when (fd-input-available-p fd (or timeout -1))
    5222           (return t))
    5223         ;; If it returned and a timeout was specified, check
    5224         ;; to see if it's been exceeded.  If so, return NIL;
    5225         ;; otherwise, adjust the remaining timeout.
    5226         ;; If there was no timeout, continue to wait forever.
    5227         (when timeout
    5228           (#_gettimeofday now (%null-ptr))
    5229           (setq timeout (- wait-end (timeval->milliseconds now)))
    5230           (if (<= timeout 0)
    5231             (return)))))))
     5249        (multiple-value-bind (win error)
     5250            (fd-input-available-p fd (or timeout -1))
     5251          (when win
     5252            (return (values t nil nil)))
     5253          (when (eql error 0)         ;timed out
     5254            (return (values nil t nil)))
     5255          ;; If it returned and a timeout was specified, check
     5256          ;; to see if it's been exceeded.  If so, return NIL;
     5257          ;; otherwise, adjust the remaining timeout.
     5258          ;; If there was no timeout, continue to wait forever.
     5259          (unless (eql error (- #$EINTR))
     5260            (return (values nil nil error)))
     5261          (when timeout
     5262            (#_gettimeofday now (%null-ptr))
     5263            (setq timeout (- wait-end (timeval->milliseconds now)))
     5264            (if (<= timeout 0)
     5265              (return (values nil t nil)))))))))
    52325266
    52335267
     
    52415275  (rlet ((now :timeval))
    52425276    (let* ((wait-end
    5243             (if timeout
    5244               (multiple-value-bind (seconds millis) (milliseconds timeout)
    5245                 (#_gettimeofday now (%null-ptr))
    5246                 (setq timeout (+ (* seconds 1000) millis))
    5247                 (+ (timeval->milliseconds now) timeout)))))
     5277            (when timeout
     5278              (#_gettimeofday now (%null-ptr))
     5279              (+ (timeval->milliseconds now) timeout))))
    52485280      (loop
    5249         ;; FD-INPUT-AVAILABLE-P can return NIL (e.g., if the
    5250         ;; thread receives an interrupt) before a timeout is
    5251         ;; reached.
    5252         (when (fd-ready-for-output-p fd (or timeout -1))
    5253           (return t))
    5254         ;; If it returned and a timeout was specified, check
    5255         ;; to see if it's been exceeded.  If so, return NIL;
    5256         ;; otherwise, adjust the remaining timeout.
    5257         ;; If there was no timeout, continue to wait forever.
    5258         (when timeout
    5259           (#_gettimeofday now (%null-ptr))
    5260           (setq timeout (- wait-end (timeval->milliseconds now)))
    5261           (if (<= timeout 0)
    5262             (return)))))))
    5263 
    5264 
    5265  
     5281        (multiple-value-bind (win error)
     5282            (fd-ready-for-output-p fd (or timeout -1))
     5283          (when win
     5284            (return (values t nil nil)))
     5285          (when (eql error 0)
     5286            (return (values nil t nil)))
     5287          (unless (eql error (- #$EINTR))
     5288            (return (values nil nil error)))
     5289          ;; If it returned and a timeout was specified, check
     5290          ;; to see if it's been exceeded.  If so, return NIL;
     5291          ;; otherwise, adjust the remaining timeout.
     5292          ;; If there was no timeout, continue to wait forever.
     5293          (when timeout
     5294            (#_gettimeofday now (%null-ptr))
     5295            (setq timeout (- wait-end (timeval->milliseconds now)))
     5296            (if (<= timeout 0)
     5297              (return (values nil t nil)))))))))
    52665298
    52675299
     
    52785310    (setf (pref (paref pollfds (:* (:struct :pollfd)) 0) :pollfd.fd) fd
    52795311          (pref (paref pollfds (:* (:struct :pollfd)) 0) :pollfd.events) #$POLLIN)
    5280     (let* ((res (ignoring-eintr (syscall syscalls::poll pollfds 1 (or milliseconds -1)))))
    5281       (> res 0))))
     5312    (let* ((res (syscall syscalls::poll pollfds 1 (or milliseconds -1))))
     5313      (declare (fixnum res))
     5314      (values (> res 0) res))))
    52825315
    52835316
     
    52865319    (setf (pref (paref pollfds (:* (:struct :pollfd)) 0) :pollfd.fd) fd
    52875320          (pref (paref pollfds (:* (:struct :pollfd)) 0) :pollfd.events) #$POLLOUT)
    5288     (let* ((res (ignoring-eintr (syscall syscalls::poll pollfds 1 (or milliseconds -1)))))
    5289       (> res 0))))
    5290 
    5291 (defun fd-urgent-data-available-p (fd &optional ticks)
    5292   (rletZ ((tv :timeval))
    5293     (ticks-to-timeval ticks tv)
    5294     (%stack-block ((errfds *fd-set-size*))
    5295       (fd-zero errfds)
    5296       (fd-set fd errfds)
    5297       (let* ((res (#_select (1+ fd) (%null-ptr) (%null-ptr)  errfds
    5298                             (if ticks tv (%null-ptr)))))
    5299         (> res 0)))))
     5321    (let* ((res (syscall syscalls::poll pollfds 1 (or milliseconds -1))))
     5322      (declare (fixnum res))
     5323      (values (> res 0)  res))))
     5324
     5325
    53005326
    53015327;;; FD-streams, built on top of the ioblock mechanism.
     
    53735399         (buf (ioblock-inbuf ioblock))
    53745400         (bufptr (io-buffer-bufptr buf))
    5375          (size (io-buffer-size buf)))
     5401         (size (io-buffer-size buf))
     5402         (avail nil))
    53765403    (setf (io-buffer-idx buf) 0
    53775404          (io-buffer-count buf) 0
    53785405          (ioblock-eof ioblock) nil)
    5379       (when (or read-p (stream-listen s))
     5406      (when (or read-p (setq avail (stream-listen s)))
     5407        (unless avail
     5408          (let* ((timeout (ioblock-input-timeout ioblock)))
     5409            (when timeout
     5410              (multiple-value-bind (win timedout error)
     5411                  (process-input-wait fd timeout)
     5412                (unless win
     5413                  (if timedout
     5414                    (error 'input-timeout :stream s)
     5415                    (stream-io-error s (- error) "read")))))))
    53805416        (let* ((n (with-eagain fd :input
    53815417                    (fd-read fd bufptr size))))
     
    54255461                (:file (fd-fsync fd))))
    54265462            octets-to-write)
     5463        (let* ((timeout (ioblock-output-timeout ioblock)))
     5464          (when timeout
     5465            (multiple-value-bind (win timedout error)
     5466                (process-output-wait fd timeout)
     5467              (unless win
     5468                (if timedout
     5469                  (error 'output-timeout :stream s)
     5470                  (stream-io-error s (- error) "write"))))))
    54275471        (let* ((written (with-eagain fd :output
    54285472                          (fd-write fd buf octets))))
     
    57695813        (normalize-external-format (stream-domain s) new)))
    57705814
     5815(defmethod stream-input-timeout ((s basic-input-stream))
     5816  (let* ((ioblock (basic-stream-ioblock s)))
     5817    (with-ioblock-input-locked (ioblock)
     5818      (let* ((timeout (ioblock-input-timeout ioblock)))
     5819        (when timeout
     5820          (values (floor timeout 1000.0)))))))
     5821
     5822(defmethod (setf stream-input-timeout) (new (s basic-input-stream))
     5823  (setq new (check-io-timeout new))
     5824  (let* ((ioblock (basic-stream-ioblock s)))
     5825    (with-ioblock-input-locked (ioblock)
     5826      (setf (ioblock-input-timeout ioblock)
     5827            (if new (round (* new 1000))))
     5828      new)))
     5829
     5830(defmethod stream-output-timeout ((s basic-output-stream))
     5831  (let* ((ioblock (basic-stream-ioblock s)))
     5832    (with-ioblock-output-locked (ioblock)
     5833      (let* ((timeout (ioblock-output-timeout ioblock)))
     5834        (when timeout
     5835          (values (floor timeout 1000.0)))))))
     5836
     5837(defmethod (setf stream-output-timeout) (new (s basic-output-stream))
     5838  (setq new (check-io-timeout new))
     5839  (let* ((ioblock (basic-stream-ioblock s)))
     5840    (with-ioblock-output-locked (ioblock)
     5841      (setf (ioblock-output-timeout ioblock)
     5842            (if new (round (* new 1000))))
     5843      new)))
     5844
     5845
     5846(defmethod stream-input-timeout ((s buffered-input-stream-mixin))
     5847  (let* ((ioblock (stream-ioblock s t)))
     5848    (with-ioblock-input-locked (ioblock)
     5849      (let* ((timeout (ioblock-input-timeout ioblock)))
     5850        (when timeout
     5851          (values (floor timeout 1000.0)))))))
     5852
     5853(defmethod (setf stream-input-timeout) (new (s buffered-input-stream-mixin))
     5854  (setq new (check-io-timeout new))
     5855  (let* ((ioblock (stream-ioblock s t)))
     5856    (with-ioblock-input-locked (ioblock)
     5857      (setf (ioblock-input-timeout ioblock)
     5858            (if new (round (* new 1000))))
     5859      new)))
     5860
     5861(defmethod stream-output-timeout ((s buffered-output-stream-mixin))
     5862  (let* ((ioblock (stream-ioblock s t)))
     5863    (with-ioblock-output-locked (ioblock)
     5864      (let* ((timeout (ioblock-output-timeout ioblock)))
     5865        (when timeout
     5866          (values (floor timeout 1000.0)))))))
     5867
     5868(defmethod (setf stream-output-timeout) (new (s buffered-output-stream-mixin))
     5869  (setq new (check-io-timeout new))
     5870  (let* ((ioblock (stream-ioblock s t)))
     5871    (with-ioblock-output-locked (ioblock)
     5872      (setf (ioblock-output-timeout ioblock)
     5873            (if new (round (* new 1000))))
     5874      new)))
     5875
    57715876
    57725877; end of L1-streams.lisp
Note: See TracChangeset for help on using the changeset viewer.