diff --git a/pkgs/racket-doc/scribblings/foreign/com-intf.scrbl b/pkgs/racket-doc/scribblings/foreign/com-intf.scrbl index 919e128981..d57f916bab 100644 --- a/pkgs/racket-doc/scribblings/foreign/com-intf.scrbl +++ b/pkgs/racket-doc/scribblings/foreign/com-intf.scrbl @@ -135,13 +135,38 @@ Like @racket[_wfun], but adds a @racket[_pointer] type (for the ``self'' argument of a method) as the first argument @racket[type-spec].} -@defform[(_hfun fun-option ... type-spec ... -> id output-expr)]{ +@defform[(_hfun fun-option ... type-spec ... -> id maybe-allow output-expr) + #:grammar + ([maybe-allow code:blank + (code:line #:allow [result-id allow?-expr])])]{ Like @racket[_wfun], but for a function that returns an -@racket[_HRESULT]. If the result is not zero, then an error is raised -using @racket[windows-error] and using @racket[id] as the name of the -failed function. Otherwise, @racket[output-expr] (as in a -@racket[_maybe-racket] for @racket[_fun]) determines the result.} +@racket[_HRESULT]. The result is bound to @racket[result-id] if +@racket[#:allow] is specified, otherwise the result is not directly +accessible. + +The @racket[_hfun] form handles the @racket[_HRESULT] value of the +foreign call as follows: + +@itemlist[ + + @item{If the result is zero or if @racket[#:allow] is specified and + @racket[allow?-expr] produces @racket[#t], then + @racket[output-expr] (as in a @racket[_maybe-wrapper] for + @racket[_fun]) determines the result.} + + @item{If the result is @cpp{RPC_E_CALL_REJECTED} or + @cpp{RPC_E_SERVERCALL_RETRYLATER}, the call is autmatically + retried up to @racket[(current-hfun-retry-count)] times with a + delay of @racket[(current-hfun-retry-delay)] seconds between + each attempt.} + + @item{Otherwise, an error is raised using @racket[windows-error] and + using @racket[id] as the name of the failed function.} + +] + +@history[#:changed "6.2.0.2" @elem{Added @racket[#:allow] and automatic retries.}]} @defform[(_hmfun fun-option ... type-spec ... -> id output-expr)]{ @@ -149,6 +174,23 @@ failed function. Otherwise, @racket[output-expr] (as in a Like @racket[_hfun], but lke @racket[_mfun] in that @racket[_pointer] is added for the first argument.} +@deftogether[( +@defparam[current-hfun-retry-count exact-nonnegative-integer? count] +@defparam[current-hfun-retry-delay secs (>=/c 0.0)] +)]{ + +Parameters that determine the behavior of automatic retries for @racket[_hfun]. + +@history[#:added "6.2.0.2"]} + + +@defproc[(HRESULT-retry? [r exact-nonnegative-integer?]) boolean?]{ + +Returns @racket[#t] if @racket[r] is @cpp{RPC_E_CALL_REJECTED} +or @cpp{RPC_E_SERVERCALL_RETRYLATER}, @racket[#f] otherwise. + +@history[#:added "6.2.0.2"]} + @deftogether[( @defthing[_GUID ctype?] diff --git a/racket/collects/ffi/unsafe/com.rkt b/racket/collects/ffi/unsafe/com.rkt index 99e873832b..3822a92c92 100644 --- a/racket/collects/ffi/unsafe/com.rkt +++ b/racket/collects/ffi/unsafe/com.rkt @@ -30,6 +30,9 @@ _HRESULT _LCID windows-error + current-hfun-retry-count + current-hfun-retry-delay + HRESULT-retry? IID_NULL IID_IUnknown _IUnknown _IUnknown-pointer _IUnknown_vt @@ -101,15 +104,15 @@ (define-ole CLSIDFromProgID (_hfun _string/utf-16 _pointer -> CLSIDFromProgID (void))) -(define-ole ProgIDFromCLSID (_fun _GUID-pointer (p : (_ptr o _pointer)) - -> (r : _HRESULT) - -> (cond - [(zero? r) - (begin0 - (cast p _pointer _string/utf-16) - (CoTaskMemFree p))] - [(= REGDB_E_CLASSNOTREG r) #f] - [else (windows-error "ProgIDFromCLSID: failed" r)]))) +(define-ole ProgIDFromCLSID (_hfun _GUID-pointer (p : (_ptr o _pointer)) + -> ProgIDFromCLSID + #:allow [r (= REGDB_E_CLASSNOTREG r)] + (cond + [(= REGDB_E_CLASSNOTREG r) #f] + [else + (begin0 + (cast p _pointer _string/utf-16) + (CoTaskMemFree p))]))) (define (progid->clsid progid) (unless (string? progid) (raise-type-error 'progid->clsid "string" progid)) @@ -281,12 +284,12 @@ (define-cstruct _IUnknown ([vt _pointer])) (define-cstruct _IUnknown_vt - ([QueryInterface (_mfun _REFIID (p : (_ptr o _pointer)) - -> (r : _HRESULT) - -> (cond - [(= r E_NOINTERFACE) #f] - [(positive? r) (windows-error "QueryInterface: failed" r)] - [else p]))] + ([QueryInterface (_hmfun _REFIID (p : (_ptr o _pointer)) + -> QueryInterface + #:allow [r (= r E_NOINTERFACE)] + (cond + [(= r E_NOINTERFACE) #f] + [else p]))] [AddRef (_mfun -> _ULONG)] [Release (_mfun -> _ULONG)])) @@ -329,17 +332,20 @@ [GetTypeInfo (_hmfun _UINT _LCID (p : (_ptr o _pointer)) -> GetTypeInfo (cast p _pointer _ITypeInfo-pointer)) #:release-with-function Release] - [GetIDsOfNames (_mfun _REFIID (_ptr i _string/utf-16) - (_UINT = 1) _LCID - (p : (_ptr o _DISPID)) - -> (r : _HRESULT) - -> (values r p))] - [Invoke (_mfun _DISPID _REFIID _LCID _WORD - _DISPPARAMS-pointer/null - _VARIANT-pointer/null - _pointer ; to _EXCEPINFO - _pointer ; to _UINT - -> _HRESULT)])) + [GetIDsOfNames (_hmfun _REFIID (_ptr i _string/utf-16) + (_UINT = 1) _LCID + (p : (_ptr o _DISPID)) + -> GetIDsOfNames + #:allow [r (not (HRESULT-retry? r))] + (values r p))] + [Invoke (_hmfun _DISPID _REFIID _LCID _WORD + _DISPPARAMS-pointer/null + _VARIANT-pointer/null + _pointer ; to _EXCEPINFO + _pointer ; to _UINT + -> Invoke + #:allow [r (not (HRESULT-retry? r))] + r)])) (define error-index-ptr (malloc 'atomic-interior _UINT)) @@ -2286,13 +2292,14 @@ (string->guid "{00020404-0000-0000-c000-000000000046}")) (define-com-interface (_IEnumVARIANT _IUnknown) - ([Next (_mfun (_ulong = 1) - (els : (_ptr o _VARIANT)) - (got : (_ptr o _ulong)) - -> (r : _HRESULT) - -> (if (= got 1) - els - #f))] + ([Next (_hmfun (_ulong = 1) + (els : (_ptr o _VARIANT)) + (got : (_ptr o _ulong)) + -> Next + #:allow [r (= r 1)] ; 1 => no more elements + (if (and (= r 0) (= got 1)) + els + #f))] ;; ... more methods ... )) @@ -2316,11 +2323,10 @@ ;; ---------------------------------------- ;; Initialize -(define-ole CoInitialize (_wfun (_pointer = #f) -> (r : _HRESULT) - -> (cond - [(= r 0) (void)] ; ok - [(= r 1) (void)] ; already initialized - [else (windows-error (format "~a: failed" 'CoInitialize) r)]))) +(define-ole CoInitialize (_hfun (_pointer = #f) + -> CoInitialize + #:allow [r (= r 1)] ; 1 => already initialized + (void))) (define inited? #f) (define (init!) diff --git a/racket/collects/ffi/unsafe/private/win32.rkt b/racket/collects/ffi/unsafe/private/win32.rkt index 5a5827428b..8f891f3f64 100644 --- a/racket/collects/ffi/unsafe/private/win32.rkt +++ b/racket/collects/ffi/unsafe/private/win32.rkt @@ -28,15 +28,39 @@ (define-syntax-rule (_wfun type ...) (_fun #:abi winapi type ...)) -;; for functions that return HRESULTs +;; for functions that return HRESULTs with +;; automatic retires on RPC_E_CALL_REJECTED +;; and RPC_E_SERVERCALL_RETRYLATER errors (define-syntax _hfun (syntax-rules (->) - [(_ type ... -> who res) - (_wfun type ... + [(_ type ... -> who #:allow [r r-ok?] res) + (_wfun #:retry (retry [count 0]) + type ... -> (r : _HRESULT) - -> (if (positive? r) - (windows-error (format "~a: failed" 'who) r) - res))])) + -> (if (or (zero? r) r-ok?) + res + (hfun-result r 'who retry count)))] + [(_ type ... -> who res) + (_hfun type ... -> who #:allow [r #f] res)])) + +(define (hfun-result r who retry count) + (cond + [(HRESULT-retry? r) + (cond + [(count . < . (current-hfun-retry-count)) + (sleep (current-hfun-retry-delay)) + (retry (add1 count))] + [else + (windows-error (format "~a: failed after ~a retries" who count) r)])] + [else + (windows-error (format "~a: failed" who) r)])) + +(define (HRESULT-retry? r) + (or (= r RPC_E_CALL_REJECTED) + (= r RPC_E_SERVERCALL_RETRYLATER))) + +(define current-hfun-retry-count (make-parameter 10)) +(define current-hfun-retry-delay (make-parameter 0.5)) (define (bit-and? a b)(not (zero? (bitwise-and a b)))) @@ -185,6 +209,8 @@ (error (format "~a (~x)" str scode)))))) (define E_NOINTERFACE #x80004002) +(define RPC_E_CALL_REJECTED #x80010001) +(define RPC_E_SERVERCALL_RETRYLATER #x8001010A) (define-kernel FormatMessageW (_wfun _DWORD _pointer _HRESULT _DWORD