|
0
|
1 ;;; with-timeout.el --- timeout hackery
|
|
|
2
|
|
|
3 ;; Copyright (C) 1992 Free Software Foundation, Inc.
|
|
|
4 ;; Keywords: extensions
|
|
|
5
|
|
|
6 ;; This file is part of XEmacs.
|
|
|
7
|
|
|
8 ;; XEmacs is free software; you can redistribute it and/or modify it
|
|
|
9 ;; under the terms of the GNU General Public License as published by
|
|
|
10 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
11 ;; any later version.
|
|
|
12
|
|
|
13 ;; XEmacs is distributed in the hope that it will be useful, but
|
|
|
14 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
|
16 ;; General Public License for more details.
|
|
|
17
|
|
|
18 ;; You should have received a copy of the GNU General Public License
|
|
|
19 ;; along with XEmacs; see the file COPYING. If not, write to the Free
|
|
|
20 ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
21
|
|
|
22 ;;; Synched up with: Not in FSF.
|
|
|
23
|
|
|
24 (defun with-timeout-timer (tag)
|
|
|
25 ;; I'm pretty sure the condition-case isn't really necessary here,
|
|
|
26 ;; but it doesn't hurt.
|
|
|
27 (condition-case () (throw tag nil) (no-catch nil)))
|
|
|
28
|
|
|
29 ;;;###autoload
|
|
|
30 (defun with-timeout-internal (with-timeout-seconds with-timeout-tag
|
|
|
31 with-timeout-body with-timeout-forms)
|
|
|
32 (let ((with-timeout-timeout nil))
|
|
|
33 (unwind-protect
|
|
|
34 (progn
|
|
|
35 (setq with-timeout-timeout (add-timeout with-timeout-seconds
|
|
|
36 'with-timeout-timer
|
|
|
37 with-timeout-tag))
|
|
|
38 (let ((value (catch with-timeout-tag
|
|
|
39 (prog1 (funcall with-timeout-body)
|
|
|
40 (setq with-timeout-tag nil)))))
|
|
|
41 (if with-timeout-tag
|
|
|
42 (funcall with-timeout-forms)
|
|
|
43 value)))
|
|
|
44 (if with-timeout-timeout
|
|
|
45 (disable-timeout with-timeout-timeout)))))
|
|
|
46
|
|
|
47 ;;;###autoload
|
|
|
48 (defmacro with-timeout (seconds-and-timeout-forms &rest body)
|
|
|
49 "Usage: (with-timeout (seconds &rest timeout-forms) &rest body)
|
|
|
50 This is just like progn, but if the given number of seconds expires before
|
|
|
51 the body returns, then timeout-forms are evaluated and returned instead.
|
|
|
52 The body won't be interrupted in the middle of a computation: the check for
|
|
|
53 the timer expiration only occurs when body does a redisplay, or prompts the
|
|
|
54 user for input, or calls accept-process-output."
|
|
|
55 (let ((seconds (car seconds-and-timeout-forms))
|
|
|
56 (timeout-forms (cdr seconds-and-timeout-forms)))
|
|
|
57 (` (with-timeout-internal (, seconds) '(, (make-symbol "_with_timeout_"))
|
|
|
58 #'(lambda () (progn (,@ body)))
|
|
|
59 #'(lambda () (progn (,@ timeout-forms)))))))
|
|
|
60
|
|
|
61 (put 'with-timeout 'lisp-indent-function 1)
|
|
|
62
|
|
|
63 ;;;###autoload
|
|
|
64 (defun yes-or-no-p-with-timeout (timeout prompt &optional default-value)
|
|
|
65 "Just like yes-or-no-p, but will time out after TIMEOUT seconds
|
|
|
66 if the user has not yes answered, returning DEFAULT-VALUE."
|
|
|
67 (with-timeout (timeout
|
|
|
68 (message (concat prompt "(yes or no) Timeout to "
|
|
|
69 (if default-value "Yes" "No")))
|
|
|
70 default-value)
|
|
|
71 (yes-or-no-p prompt)))
|
|
|
72
|
|
|
73 ;;;###autoload
|
|
|
74 (defun y-or-n-p-with-timeout (timeout prompt &optional default-value)
|
|
|
75 "Just like y-or-n-p, but will time out after TIMEOUT seconds
|
|
|
76 if the user has not yes answered, returning DEFAULT-VALUE."
|
|
|
77 (with-timeout (timeout
|
|
|
78 (message (concat prompt "(yes or no) Timeout to "
|
|
|
79 (if default-value "Yes" "No")))
|
|
|
80 default-value)
|
|
|
81 (y-or-n-p prompt)))
|
