Changeset 8603


Ignore:
Timestamp:
Feb 25, 2008, 7:36:34 PM (12 years ago)
Author:
gb
Message:

Stream I/O deadline changes, based on patch from Hans Hubner.

Location:
trunk/source
Files:
4 edited

Legend:

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

    r8484 r8603  
    381381  (:report (lambda (c s)
    382382             (format s "Output timeout on ~s" (stream-error-stream c)))))
     383(define-condition communication-deadline-expired (io-timeout)
     384  ()
     385  (:report (lambda (c s)
     386             (format s "Communication deadline timeout on ~s" (stream-error-stream c)))))
     387 
     388
    383389
    384390
  • trunk/source/level-1/l1-sockets.lisp

    r8485 r8603  
    605605                    local-filename remote-filename sharing basic
    606606                    external-format (auto-close t)
    607                     connect-timeout)
     607                    connect-timeout input-timeout output-timeout deadline)
    608608  "Create and return a new socket."
    609609  (declare (dynamic-extent keys))
     
    612612                   local-port local-host backlog class out-of-band-inline
    613613                   local-filename remote-filename sharing basic external-format
    614                    auto-close  connect-timeout))
     614                   auto-close connect-timeout input-timeout output-timeout deadline))
    615615  (ecase address-family
    616616    ((:file) (apply #'make-file-socket keys))
     
    698698
    699699
    700 (defun make-tcp-stream (fd &key (format :bivalent) external-format (class 'tcp-stream) sharing (basic t) (auto-close t)  &allow-other-keys)
     700(defun make-tcp-stream (fd
     701                        &key (format :bivalent)
     702                             external-format
     703                             (class 'tcp-stream)
     704                             sharing
     705                             (basic t)
     706                             (auto-close t)
     707                             input-timeout
     708                             output-timeout
     709                             deadline
     710                        &allow-other-keys)
    701711  (let* ((external-format (normalize-external-format :socket external-format)))
    702712    (let ((element-type (ecase format
     
    714724                      :line-termination (external-format-line-termination external-format)
    715725                      :basic basic
    716                       :auto-close auto-close))))
    717 
    718 (defun make-file-socket-stream (fd &key (format :bivalent) external-format (class 'file-socket-stream)  sharing basic (auto-close t) &allow-other-keys)
     726                      :auto-close auto-close
     727                      :input-timeout input-timeout
     728                      :output-timeout output-timeout
     729                      :deadline deadline))))
     730
     731(defun make-file-socket-stream (fd
     732                                &key (format :bivalent)
     733                                external-format
     734                                (class 'file-socket-stream)
     735                                sharing
     736                                basic
     737                                (auto-close t)
     738                                input-timeout
     739                                output-timeout
     740                                deadline
     741                                &allow-other-keys)
    719742  (let* ((external-format (normalize-external-format :socket external-format)))
    720743 
  • trunk/source/level-1/l1-streams.lisp

    r8596 r8603  
    30653065                            encoding
    30663066                            line-termination
     3067                            input-timeout
     3068                            output-timeout
     3069                            deadline
    30673070                            &allow-other-keys)
    30683071  (declare (ignorable element-shift))
     
    31573160      (when bom-info
    31583161        (ioblock-check-input-bom ioblock bom-info sharing)))
     3162    (setf (ioblock-input-timeout ioblock) input-timeout)
     3163    (setf (ioblock-output-timeout ioblock) output-timeout)
     3164    (setf (ioblock-deadline ioblock) deadline)
    31593165    ioblock))
    31603166
     
    32883294      (8 (ash octets -3)))))
    32893295
    3290    
     3296
     3297(defun milliseconds-until-deadline (deadline ioblock)
     3298  (let* ((now (get-internal-real-time)))
     3299    (if (> now deadline)
     3300      (error 'communication-deadline-expired :stream (ioblock-stream ioblock))
     3301      (values (round (- deadline now) (/ internal-time-units-per-second 1000))))))
    32913302
    32923303
     
    33043315                          encoding
    33053316                          line-termination
    3306                           auto-close)
     3317                          auto-close
     3318                          input-timeout
     3319                          output-timeout
     3320                          deadline)
    33073321  (let* ((elements-per-buffer (optimal-buffer-size fd element-type)))
    33083322    (when line-termination
     
    33333347                                 :character-p character-p
    33343348                                 :encoding encoding
    3335                                  :line-termination line-termination)))
     3349                                 :line-termination line-termination
     3350                                 :input-timeout input-timeout
     3351                                 :output-timeout output-timeout
     3352                                 :deadline deadline)))
    33363353      (if auto-close
    33373354        (terminate-when-unreachable stream
     
    38073824           (synonym-method stream-surrounding-characters)
    38083825           (synonym-method stream-input-timeout)
    3809            (synonym-method stream-output-timeout))
     3826           (synonym-method stream-output-timeout)
     3827           (synonym-method stream-deadline))
    38103828
    38113829(defmethod (setf input-stream-timeout) (new (s synonym-stream))
     
    38873905  (two-way-output-method stream-write-list l c)
    38883906  (two-way-output-method stream-write-vector v start end)
    3889   (two-way-output-method stream-output-timeout))
     3907  (two-way-output-method stream-output-timeout)
     3908  (two-way-output-method stream-deadline))
    38903909
    38913910(defmethod (setf stream-input-timeout) (new (s two-way-stream))
     
    38943913(defmethod (setf stream-output-timeout) (new (s two-way-stream))
    38953914  (setf (stream-output-timeout (two-way-stream-output-stream s)) new))
     3915
     3916(defmethod (setf stream-deadline) (new (s two-way-stream))
     3917  (setf (stream-deadline (two-way-stream-output-stream s)) new))
    38963918
    38973919(defmethod stream-device ((s two-way-stream) direction)
     
    54195441      (when (or read-p (setq avail (stream-listen s)))
    54205442        (unless avail
    5421           (let* ((timeout (ioblock-input-timeout ioblock)))
     5443          (let* ((deadline (ioblock-deadline ioblock))
     5444                 (timeout
     5445                  (if deadline
     5446                    (milliseconds-until-deadline deadline ioblock)
     5447                    (ioblock-input-timeout ioblock))))
    54225448            (when timeout
    54235449              (multiple-value-bind (win timedout error)
     
    54255451                (unless win
    54265452                  (if timedout
    5427                     (error 'input-timeout :stream s)
     5453                    (error (if deadline
     5454                             'communication-deadline-expired
     5455                             'input-timeout)
     5456                           :stream s)
    54285457                    (stream-io-error s (- error) "read")))))))
    54295458        (let* ((n (with-eagain fd :input
     
    54745503                (:file (fd-fsync fd))))
    54755504            octets-to-write)
    5476         (let* ((timeout (ioblock-output-timeout ioblock)))
     5505        (let* ((deadline (ioblock-deadline ioblock))
     5506               (timeout
     5507                (if deadline
     5508                  (milliseconds-until-deadline deadline ioblock)
     5509                  (ioblock-output-timeout ioblock))))
    54775510          (when timeout
    54785511            (multiple-value-bind (win timedout error)
     
    54805513              (unless win
    54815514                (if timedout
    5482                   (error 'output-timeout :stream s)
     5515                  (error (if deadline
     5516                           'communication-deadline-expired
     5517                           'output-timeout)
     5518                         :stream s)
    54835519                  (stream-io-error s (- error) "write"))))))
    54845520        (let* ((written (with-eagain fd :output
     
    58545890      new)))
    58555891
     5892(defmethod stream-deadline ((s basic-output-stream))
     5893  (let* ((ioblock (basic-stream-ioblock s)))
     5894    (with-ioblock-output-locked (ioblock)
     5895      (ioblock-deadline ioblock))))
     5896 
     5897(defmethod (setf stream-deadline) (new (s basic-output-stream))
     5898  (let* ((ioblock (basic-stream-ioblock s)))
     5899    (with-ioblock-output-locked (ioblock)
     5900      (setf (ioblock-deadline ioblock) new)
     5901      new)))
     5902
     5903
    58565904
    58575905(defmethod stream-input-timeout ((s buffered-input-stream-mixin))
     
    58855933      new)))
    58865934
     5935(defmethod stream-deadline ((s buffered-output-stream-mixin))
     5936  (let* ((ioblock (stream-ioblock s t)))
     5937    (with-ioblock-output-locked (ioblock)
     5938      (ioblock-deadline ioblock))))
     5939 
     5940(defmethod (setf stream-deadline) (new (s buffered-output-stream-mixin))
     5941  (let* ((ioblock (stream-ioblock s t)))
     5942    (with-ioblock-output-locked (ioblock)
     5943      (setf (ioblock-deadline ioblock) new)
     5944      new)))
     5945
     5946
    58875947
    58885948; end of L1-streams.lisp
  • trunk/source/lib/ccl-export-syms.lisp

    r8510 r8603  
    565565     with-input-timeout
    566566     with-output-timeout
     567     stream-deadline
    567568
    568569     input-timeout
    569570     output-timeout
     571     communication-deadline-expired
    570572
    571573     make-heap-ivector
Note: See TracChangeset for help on using the changeset viewer.