Mercurial > hg > xemacs-beta

comparison lisp/utils/with-timeout.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 0293115a14e9
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
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)))