mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-06 04:00:26 +02:00
8d388c97e7
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
133 lines
4.5 KiB
Scheme
133 lines
4.5 KiB
Scheme
;;;; sandbox.test --- tests guile's evaluator -*- scheme -*-
|
|
;;;; Copyright (C) 2017 Free Software Foundation, Inc.
|
|
;;;;
|
|
;;;; This library is free software; you can redistribute it and/or
|
|
;;;; 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
|
|
|
|
(define-module (test-suite sandbox)
|
|
#:use-module (test-suite lib)
|
|
#:use-module (ice-9 sandbox))
|
|
|
|
|
|
(define exception:bad-expression
|
|
(cons 'syntax-error "Bad expression"))
|
|
|
|
(define exception:failed-match
|
|
(cons 'syntax-error "failed to match any pattern"))
|
|
|
|
(define exception:not-a-list
|
|
(cons 'wrong-type-arg "Not a list"))
|
|
|
|
(define exception:wrong-length
|
|
(cons 'wrong-type-arg "wrong length"))
|
|
|
|
(define (usleep-loop usecs)
|
|
(unless (zero? usecs)
|
|
(usleep-loop (usleep usecs))))
|
|
(define (busy-loop)
|
|
(busy-loop))
|
|
|
|
(with-test-prefix "time limit"
|
|
(pass-if "0 busy loop"
|
|
(call-with-time-limit 0 busy-loop (lambda () #t)))
|
|
(pass-if "0.001 busy loop"
|
|
(call-with-time-limit 0.001 busy-loop (lambda () #t)))
|
|
(pass-if "0 sleep"
|
|
(call-with-time-limit 0 (lambda () (usleep-loop #e1e6) #f)
|
|
(lambda () #t)))
|
|
(pass-if "0.001 sleep"
|
|
(call-with-time-limit 0.001 (lambda () (usleep-loop #e1e6) #f)
|
|
(lambda () #t))))
|
|
|
|
(define (alloc-loop)
|
|
(let lp ((ret #t))
|
|
(and ret
|
|
(lp (cons #t #t)))))
|
|
(define (recur-loop)
|
|
(1+ (recur-loop)))
|
|
|
|
(with-test-prefix "allocation limit"
|
|
(pass-if "0 alloc loop"
|
|
(call-with-allocation-limit 0 alloc-loop (lambda () #t)))
|
|
(pass-if "1e6 alloc loop"
|
|
(call-with-allocation-limit #e1e6 alloc-loop (lambda () #t)))
|
|
(pass-if "0 recurse"
|
|
(call-with-allocation-limit 0 recur-loop (lambda () #t)))
|
|
(pass-if "1e6 recurse"
|
|
(call-with-allocation-limit #e1e6 recur-loop (lambda () #t))))
|
|
|
|
(define-syntax-rule (pass-if-unbound foo)
|
|
(pass-if-exception (format #f "~a unavailable" 'foo)
|
|
exception:unbound-var
|
|
(unless (defined? 'SIGALRM) (throw 'unsupported))
|
|
(eval-in-sandbox 'foo))
|
|
)
|
|
|
|
(with-test-prefix "eval-in-sandbox"
|
|
(pass-if-equal 42
|
|
(begin
|
|
(unless (defined? 'SIGALRM)
|
|
(throw 'unsupported))
|
|
(eval-in-sandbox 42)))
|
|
(pass-if-equal 'foo
|
|
(begin
|
|
(unless (defined? 'SIGALRM)
|
|
(throw 'unsupported))
|
|
(eval-in-sandbox ''foo)))
|
|
(pass-if-equal '(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!)
|
|
(pass-if-unbound open-file)
|
|
(pass-if-unbound current-input-port)
|
|
(pass-if-unbound call-with-output-file)
|
|
(pass-if-unbound vector-set!)
|
|
(pass-if-equal vector-set!
|
|
(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)))
|