|
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
|
|
16
|
19 ;; along with XEmacs; see the file COPYING. If not, write to the
|
|
|
20 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
|
21 ;; Boston, MA 02111-1307, USA.
|
|
0
|
22
|
|
|
23 ;;; Synched up with: Not in FSF.
|
|
|
24
|
|
|
25 (defun with-timeout-timer (tag)
|
|
|
26 ;; I'm pretty sure the condition-case isn't really necessary here,
|
|
|
27 ;; but it doesn't hurt.
|
|
|
28 (condition-case () (throw tag nil) (no-catch nil)))
|
|
|
29
|
|
|
30 ;;;###autoload
|
|
|
31 (defun with-timeout-internal (with-timeout-seconds with-timeout-tag
|
|
|
32 with-timeout-body with-timeout-forms)
|
|
|
33 (let ((with-timeout-timeout nil))
|
|
|
34 (unwind-protect
|
|
|
35 (progn
|
|
|
36 (setq with-timeout-timeout (add-timeout with-timeout-seconds
|
|
|
37 'with-timeout-timer
|
|
|
38 with-timeout-tag))
|
|
|
39 (let ((value (catch with-timeout-tag
|
|
|
40 (prog1 (funcall with-timeout-body)
|
|
|
41 (setq with-timeout-tag nil)))))
|
|
|
42 (if with-timeout-tag
|
|
|
43 (funcall with-timeout-forms)
|
|
|
44 value)))
|
|
|
45 (if with-timeout-timeout
|
|
|
46 (disable-timeout with-timeout-timeout)))))
|
|
|
47
|
|
|
48 ;;;###autoload
|
|
|
49 (defmacro with-timeout (seconds-and-timeout-forms &rest body)
|
|
|
50 "Usage: (with-timeout (seconds &rest timeout-forms) &rest body)
|
|
|
51 This is just like progn, but if the given number of seconds expires before
|
|
|
52 the body returns, then timeout-forms are evaluated and returned instead.
|
|
|
53 The body won't be interrupted in the middle of a computation: the check for
|
|
|
54 the timer expiration only occurs when body does a redisplay, or prompts the
|
|
|
55 user for input, or calls accept-process-output."
|
|
|
56 (let ((seconds (car seconds-and-timeout-forms))
|
|
|
57 (timeout-forms (cdr seconds-and-timeout-forms)))
|
|
|
58 (` (with-timeout-internal (, seconds) '(, (make-symbol "_with_timeout_"))
|
|
|
59 #'(lambda () (progn (,@ body)))
|
|
|
60 #'(lambda () (progn (,@ timeout-forms)))))))
|
|
|
61
|
|
|
62 (put 'with-timeout 'lisp-indent-function 1)
|
|
|
63
|
|
|
64 ;;;###autoload
|
|
|
65 (defun yes-or-no-p-with-timeout (timeout prompt &optional default-value)
|
|
|
66 "Just like yes-or-no-p, but will time out after TIMEOUT seconds
|
|
|
67 if the user has not yes answered, returning DEFAULT-VALUE."
|
|
|
68 (with-timeout (timeout
|
|
|
69 (message (concat prompt "(yes or no) Timeout to "
|
|
|
70 (if default-value "Yes" "No")))
|
|
|
71 default-value)
|
|
|
72 (yes-or-no-p prompt)))
|
|
|
73
|
|
|
74 ;;;###autoload
|
|
|
75 (defun y-or-n-p-with-timeout (timeout prompt &optional default-value)
|
|
|
76 "Just like y-or-n-p, but will time out after TIMEOUT seconds
|
|
|
77 if the user has not yes answered, returning DEFAULT-VALUE."
|
|
|
78 (with-timeout (timeout
|
|
|
79 (message (concat prompt "(yes or no) Timeout to "
|
|
|
80 (if default-value "Yes" "No")))
|
|
|
81 default-value)
|
|
|
82 (y-or-n-p prompt)))
|
