02/02: store: 'with-store' uses 'with-exception-handler'.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 376ba0ce570993cf6cdbed19596a245826308382
Author: Ludovic Courtès <address@hidden>
AuthorDate: Sat Apr 4 23:58:05 2020 +0200

    store: 'with-store' uses 'with-exception-handler'.
    
    This ensures the stack is not unwound before the exception is re-thrown,
    as was the case since 8ed597f4a261fe188de82cd1f5daed83dba948eb, leading
    to '&store-protocol-error' being uncaught by 'with-error-handling'
    in (guix scripts build) & co.
    
    * guix/store.scm (call-with-store): Define 'thunk'.  Add 'cond-expand'
    to use 'with-exception-handler' on 'guile-3' and 'catch' otherwise.
---
 guix/store.scm | 29 +++++++++++++++++++----------
 1 file changed, 19 insertions(+), 10 deletions(-)

diff --git a/guix/store.scm b/guix/store.scm
index 1dd5c95..fb4b92e 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -623,16 +623,25 @@ connection.  Use with care."
 (define (call-with-store proc)
   "Call PROC with an open store connection."
   (let ((store (open-connection)))
-    (catch #t
-      (lambda ()
-        (parameterize ((current-store-protocol-version
-                        (store-connection-version store)))
-          (let ((result (proc store)))
-            (close-connection store)
-            result)))
-      (lambda (key . args)
-        (close-connection store)
-        (apply throw key args)))))
+    (define (thunk)
+      (parameterize ((current-store-protocol-version
+                      (store-connection-version store)))
+        (let ((result (proc store)))
+          (close-connection store)
+          result)))
+
+    (cond-expand
+      (guile-3
+       (with-exception-handler (lambda (exception)
+                                 (close-connection store)
+                                 (raise-exception exception))
+         thunk))
+      (else                                       ;Guile 2.2
+       (catch #t
+         thunk
+         (lambda (key . args)
+           (close-connection store)
+           (apply throw key args)))))))
 
 (define-syntax-rule (with-store store exp ...)
   "Bind STORE to an open connection to the store and evaluate EXPs;