diff options
| -rw-r--r-- | module/calp/util.scm | 28 | ||||
| -rw-r--r-- | tests/let-env.scm | 22 |
2 files changed, 38 insertions, 12 deletions
diff --git a/module/calp/util.scm b/module/calp/util.scm index 6cee1b0f..70091b2e 100644 --- a/module/calp/util.scm +++ b/module/calp/util.scm @@ -554,23 +554,27 @@ -;;; TODO shouldn't this use dynamic-wind? To handle non-local exits? + (define-syntax let-env (syntax-rules () [(_ ((name value) ...) body ...) - (let ((env-pairs - (map (lambda (n new-value) - (list n new-value (getenv n))) - (list (symbol->string (quote name)) ...) - (list value ...)))) - (for-each (lambda (pair) (setenv (car pair) (cadr pair))) - env-pairs) - (let ((return (begin body ...))) - (for-each (lambda (pair) (setenv (car pair) (caddr pair))) - env-pairs) - return))])) + (let ((env-pairs #f)) + (dynamic-wind + (lambda () + (set! env-pairs + (map (lambda (n new-value) + (list n new-value (getenv n))) + (list (symbol->string (quote name)) ...) + (list value ...))) + (for-each (lambda (pair) (setenv (car pair) (cadr pair))) + env-pairs)) + (lambda () body ...) + (lambda () + (for-each (lambda (pair) (setenv (car pair) (caddr pair))) + env-pairs))))])) + (define-public (uuidgen) ((@ (rnrs io ports) call-with-port) diff --git a/tests/let-env.scm b/tests/let-env.scm new file mode 100644 index 00000000..0fe77539 --- /dev/null +++ b/tests/let-env.scm @@ -0,0 +1,22 @@ +(((guile) setenv getenv) + ((calp util) let-env)) + +(setenv "CALP_TEST_ENV" "1") +(test-equal "Ensure we have set value beforehand" + "1" (getenv "CALP_TEST_ENV")) +(let-env ((CALP_TEST_ENV "2")) + (test-equal "Test our local override" + "2" (getenv "CALP_TEST_ENV"))) +(test-equal "Test that we have returned" + "1" (getenv "CALP_TEST_ENV")) + +(catch 'test-error + (lambda () + (let-env ((CALP_TEST_ENV "2")) + (test-equal "Test our local override again" + "2" (getenv "CALP_TEST_ENV")) + (throw 'test-error))) + list) + +(test-equal "Test restoration after non-local exit" + "1" (getenv "CALP_TEST_ENV")) |