Coverage report: /home/ellis/.stash/lisp/cl-plus-ssl/src/ssl-funcall.lisp

KindCoveredAll%
expression782 8.5
branch04 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;;; -*- Mode: LISP; Syntax: COMMON-LISP; indent-tabs-mode: nil; coding: utf-8; show-trailing-whitespace: t -*-
2
 ;;;
3
 ;;; Copyright (C) contributors as per cl+ssl git history
4
 ;;;
5
 ;;; See LICENSE for details.
6
 
7
 (eval-when (:compile-toplevel)
8
   (declaim
9
    (optimize (speed 3) (space 1) (safety 1) (debug 0) (compilation-speed 0))))
10
 
11
 (in-package :cl+ssl)
12
 
13
 #+openmcl
14
 (defmethod stream-deadline ((stream ccl::basic-stream))
15
   (ccl::ioblock-deadline (ccl::stream-ioblock stream t)))
16
 #+openmcl
17
 (defmethod stream-deadline ((stream t))
18
   nil)
19
 
20
 ;;; Waiting for output to be possible
21
 
22
 #+clozure-common-lisp
23
 (defun milliseconds-until-deadline (deadline stream)
24
   (let* ((now (get-internal-real-time)))
25
     (if (> now deadline)
26
         (error 'ccl::communication-deadline-expired :stream stream)
27
         (values
28
          (round (- deadline now) (/ internal-time-units-per-second 1000))))))
29
 
30
 #+clozure-common-lisp
31
 (defun output-wait (stream fd deadline)
32
   (unless deadline
33
     (setf deadline (stream-deadline (ssl-stream-socket stream))))
34
   (let* ((timeout
35
           (if deadline
36
               (milliseconds-until-deadline deadline stream)
37
               nil)))
38
     (multiple-value-bind (win timedout error)
39
         (ccl::process-output-wait fd timeout)
40
       (unless win
41
         (if timedout
42
             (error 'ccl::communication-deadline-expired :stream stream)
43
             (ccl::stream-io-error stream (- error) "write"))))))
44
 
45
 (defun seconds-until-deadline (deadline)
46
   (/ (- deadline (get-internal-real-time))
47
      internal-time-units-per-second))
48
 
49
 #+sbcl
50
 (defun output-wait (stream fd deadline)
51
   (declare (ignore stream))
52
   (let ((timeout
53
          ;; *deadline* is handled by wait-until-fd-usable automatically,
54
          ;; but we need to turn a user-specified deadline into a timeout
55
          (when deadline
56
            (seconds-until-deadline deadline))))
57
     (sb-sys:wait-until-fd-usable fd :output timeout)))
58
 
59
 #+allegro
60
 (eval-when (:compile-top-level :load-top-level :execute)
61
   (require :process))
62
 
63
 #+allegro
64
 (defun output-wait (stream fd deadline)
65
   (declare (ignore stream))
66
   (let ((timeout
67
          (when deadline
68
            (seconds-until-deadline deadline))))
69
     (mp:process-wait-with-timeout "cl+ssl waiting for output"
70
                                   timeout
71
                                   'excl:write-no-hang-p
72
                                   fd)))
73
 
74
 #-(or clozure-common-lisp sbcl allegro)
75
 (defun output-wait (stream fd deadline)
76
   (declare (ignore stream fd deadline))
77
   ;; This situation means that the lisp set our fd to non-blocking mode,
78
   ;; and streams.lisp didn't know how to undo that.
79
   (warn "cl+ssl::output-wait is not implemented for this lisp, but a non-blocking stream is encountered"))
80
 
81
 
82
 ;;; Waiting for input to be possible
83
 
84
 #+clozure-common-lisp
85
 (defun input-wait (stream fd deadline)
86
   (unless deadline
87
     (setf deadline (stream-deadline (ssl-stream-socket stream))))
88
   (let* ((timeout
89
           (if deadline
90
               (milliseconds-until-deadline deadline stream)
91
               nil)))
92
     (multiple-value-bind (win timedout error)
93
         (ccl::process-input-wait fd timeout)
94
       (unless win
95
         (if timedout
96
             (error 'ccl::communication-deadline-expired :stream stream)
97
             (ccl::stream-io-error stream (- error) "read"))))))
98
 
99
 #+sbcl
100
 (defun input-wait (stream fd deadline)
101
   (declare (ignore stream))
102
   (let ((timeout
103
          ;; *deadline* is handled by wait-until-fd-usable automatically,
104
          ;; but we need to turn a user-specified deadline into a timeout
105
          (when deadline
106
            (seconds-until-deadline deadline))))
107
     (sb-sys:wait-until-fd-usable fd :input timeout)))
108
 
109
 #+allegro
110
 (defun input-wait (stream fd deadline)
111
   (declare (ignore stream))
112
   (let ((timeout
113
          (when deadline
114
            (max 0 (seconds-until-deadline deadline)))))
115
     (mp:wait-for-input-available fd
116
                                  :timeout timeout
117
                                  :whostate "cl+ssl waiting for input")))
118
 
119
 #+lispworks
120
 (defun input-wait (stream fd deadline)
121
   (declare (ignore fd))
122
 
123
   (let* ((timeout
124
            (when deadline
125
              (max 0 (seconds-until-deadline deadline)))))
126
     (system:wait-for-input-streams (list (ssl-stream-socket stream))
127
                                    :timeout timeout
128
                                    :wait-reason "cl+ssl waiting for input")))
129
 
130
 #-(or clozure-common-lisp sbcl allegro lispworks)
131
 (defun input-wait (stream fd deadline)
132
   (declare (ignore stream fd deadline))
133
   ;; This situation means that the lisp set our fd to non-blocking mode,
134
   ;; and streams.lisp didn't know how to undo that.
135
   (warn "cl+ssl::input-wait is not implemented for this lisp, but a non-blocking stream is encountered"))
136
 
137
 ;;; Funcall wrapper
138
 
139
 (declaim (inline ensure-ssl-funcall))
140
 (defun ensure-ssl-funcall (stream success-test func handle &rest other-args)
141
   (loop
142
      (let ((ret
143
             (let ((*bio-socket* (ssl-stream-socket stream))) ;for Lisp-BIO callbacks
144
               (apply func handle other-args))))
145
        (when (funcall success-test ret)
146
          (return ret))
147
        (let ((error (ssl-get-error handle ret)))
148
          (case error
149
            (#.+ssl-error-want-read+
150
             (input-wait stream
151
                         (ssl-get-fd handle)
152
                         (ssl-stream-deadline stream)))
153
            (#.+ssl-error-want-write+
154
             (output-wait stream
155
                          (ssl-get-fd handle)
156
                          (ssl-stream-deadline stream)))
157
            (t
158
             (ssl-signal-error handle func error ret)))))))
159
 
160
 (declaim (inline nonblocking-ssl-funcall))
161
 (defun nonblocking-ssl-funcall (stream success-test func handle &rest other-args)
162
   (loop
163
      (let ((ret
164
             (let ((*bio-socket* (ssl-stream-socket stream))) ;for Lisp-BIO callbacks
165
               (apply func handle other-args))))
166
        (when (funcall success-test ret)
167
          (return ret))
168
        (let ((error (ssl-get-error handle ret)))
169
          (case error
170
            ((#.+ssl-error-want-read+ #.+ssl-error-want-write+)
171
             (return ret))
172
            (t
173
             (ssl-signal-error handle func error ret)))))))
174