mike121 pushed a commit to branch wip-mingw-2025
in repository guile.
commit 8d388c97e7330b69b1ed332c51113269f0aba9a2
Author: Michael Gran <spk...@yahoo.com>
AuthorDate: Tue Jul 4 10:26:49 2023 -0700
Add option to disable time limit in eval-in-sandbox
On systems without SIGALRM, the other features of eval-in-sandbox
may still be useful. This adds the option to set #:time-limit to
#f to indicate no timeout.
* NEWS: updated
* module/ice-9/sandbox.scm (eval-in-sandbox): allow #:time-limit key
to be #f to disable time limit
* doc/ref/api-evaluation.texi (eval-in-sandbox): update documentation
* test-suite/tests/sandbox.scm ("eval-in-sandbox"): throw unsupported
if no SIGALARM
("eval-in-sandbox no timeout"): new tests for eval-in-sandbox
---
NEWS | 6 ++++++
doc/ref/api-evaluation.texi | 8 +++----
module/ice-9/sandbox.scm | 29 ++++++++++++++++---------
test-suite/tests/sandbox.test | 50 +++++++++++++++++++++++++++++++++++++------
4 files changed, 73 insertions(+), 20 deletions(-)
diff --git a/NEWS b/NEWS
index 326617fd8..dfcd4fe0d 100644
--- a/NEWS
+++ b/NEWS
@@ -103,6 +103,12 @@ have 'sh' in /bin.
** -Werror=array-bounds is now added to CFLAGS when available
This catches <https://bugs.gnu.org/76907>
+** Add option to disable time limit in 'eval-in-sandbox'
+
+eval-in-sandbox is modified so that #:time-limit accepts #f to disable
+the time limit. Systems without SIGALRM can use eval-in-sandbox if the
+time limit is disabled.
+
* Bug fixes
** `basename` now checks the suffix against the base name, not the full path
diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi
index 68bf38e54..1877dcca6 100644
--- a/doc/ref/api-evaluation.texi
+++ b/doc/ref/api-evaluation.texi
@@ -1396,10 +1396,10 @@ The main sandbox interface is @code{eval-in-sandbox}.
[#:bindings all-pure-bindings] @
[#:module (make-sandbox-module bindings)] @
[#:sever-module? #t]
-Evaluate the Scheme expression @var{exp} within an isolated
-"sandbox". Limit its execution to @var{time-limit} seconds of
-wall-clock time, and limit its allocation to @var{allocation-limit}
-bytes.
+Evaluate the Scheme expression @var{exp} within an isolated "sandbox".
+When @var{time-limit} is a number and is not @code{#f}, limit its
+execution to @var{time-limit} seconds of wall-clock time. Limit its
+allocation to @var{allocation-limit} bytes.
The evaluation will occur in @var{module}, which defaults to the result
of calling @code{make-sandbox-module} on @var{bindings}, which itself
diff --git a/module/ice-9/sandbox.scm b/module/ice-9/sandbox.scm
index 601485cce..aa2e02132 100644
--- a/module/ice-9/sandbox.scm
+++ b/module/ice-9/sandbox.scm
@@ -6,18 +6,18 @@
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
-;;;;
+;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
-;;;;
+;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
;;; Commentary:
-;;;
+;;;
;;; Code:
(define-module (ice-9 sandbox)
@@ -217,9 +217,9 @@ respectively."
(module (make-sandbox-module bindings))
(sever-module? #t))
"Evaluate the Scheme expression @var{exp} within an isolated
-\"sandbox\". Limit its execution to @var{time-limit} seconds of
-wall-clock time, and limit its allocation to @var{allocation-limit}
-bytes.
+\"sandbox\". When @var{time-limit} is true, limit its execution to
+@var{time-limit} seconds of wall-clock time. Limit its allocation to
+@var{allocation-limit} bytes.
The evaluation will occur in @var{module}, which defaults to the result
of calling @code{make-sandbox-module} on @var{bindings}, which itself
@@ -256,10 +256,19 @@ allocation limit is exceeded, an exception will be thrown
to the
(dynamic-wind
(lambda () #t)
(lambda ()
- (call-with-time-and-allocation-limits
- time-limit allocation-limit
- (lambda ()
- (eval exp module))))
+ (if time-limit
+ (call-with-time-and-allocation-limits
+ time-limit allocation-limit
+ (lambda ()
+ (eval exp module)))
+
+ (call-with-allocation-limit
+ allocation-limit
+ (lambda ()
+ (eval exp module))
+ (lambda ()
+ (scm-error 'limit-exceeded "with-resource-limits"
+ "Allocation limit exceeded" '() #f)))))
(lambda () (when sever-module? (sever-module! module)))))
diff --git a/test-suite/tests/sandbox.test b/test-suite/tests/sandbox.test
index 3a1653a97..96651a2b1 100644
--- a/test-suite/tests/sandbox.test
+++ b/test-suite/tests/sandbox.test
@@ -69,16 +69,27 @@
(define-syntax-rule (pass-if-unbound foo)
(pass-if-exception (format #f "~a unavailable" 'foo)
- exception:unbound-var (eval-in-sandbox 'foo))
+ exception:unbound-var
+ (unless (defined? 'SIGALRM) (throw 'unsupported))
+ (eval-in-sandbox 'foo))
)
(with-test-prefix "eval-in-sandbox"
(pass-if-equal 42
- (eval-in-sandbox 42))
+ (begin
+ (unless (defined? 'SIGALRM)
+ (throw 'unsupported))
+ (eval-in-sandbox 42)))
(pass-if-equal 'foo
- (eval-in-sandbox ''foo))
+ (begin
+ (unless (defined? 'SIGALRM)
+ (throw 'unsupported))
+ (eval-in-sandbox ''foo)))
(pass-if-equal '(1 . 2)
- (eval-in-sandbox '(cons 1 2)))
+ (begin
+ (unless (defined? 'SIGALRM)
+ (throw 'unsupported))
+ (eval-in-sandbox '(cons 1 2))))
(pass-if-unbound @@)
(pass-if-unbound foo)
(pass-if-unbound set!)
@@ -87,9 +98,36 @@
(pass-if-unbound call-with-output-file)
(pass-if-unbound vector-set!)
(pass-if-equal vector-set!
- (eval-in-sandbox 'vector-set!
- #:bindings all-pure-and-impure-bindings))
+ (begin
+ (unless (defined? 'SIGALRM)
+ (throw 'unsupported))
+ (eval-in-sandbox 'vector-set!
+ #:bindings all-pure-and-impure-bindings)))
(pass-if-exception "limit exceeded"
'(limit-exceeded . "")
+ (unless (defined? 'SIGALRM) (throw 'unsupported))
(eval-in-sandbox '(let lp () (lp)))))
+(define-syntax-rule (pass-if-unbound-no-timeout foo)
+ (pass-if-exception (format #f "~a unavailable" 'foo)
+ exception:unbound-var (eval-in-sandbox 'foo #:time-limit #f))
+ )
+
+(with-test-prefix "eval-in-sandbox no timeout"
+ (pass-if-equal 42
+ (eval-in-sandbox 42 #:time-limit #f))
+ (pass-if-equal 'foo
+ (eval-in-sandbox ''foo #:time-limit #f))
+ (pass-if-equal '(1 . 2)
+ (eval-in-sandbox '(cons 1 2) #:time-limit #f))
+ (pass-if-unbound-no-timeout @@)
+ (pass-if-unbound-no-timeout foo)
+ (pass-if-unbound-no-timeout set!)
+ (pass-if-unbound-no-timeout open-file)
+ (pass-if-unbound-no-timeout current-input-port)
+ (pass-if-unbound-no-timeout call-with-output-file)
+ (pass-if-unbound-no-timeout vector-set!)
+ (pass-if-equal vector-set!
+ (eval-in-sandbox 'vector-set!
+ #:bindings all-pure-and-impure-bindings
+ #:time-limit #f)))
