lisp/emacs-lock.el: New file. Old one moved to lisp/obsolete/.

1 files changed, 210 insertions, 71 deletions

diff --git a/lisp/emacs-lock.el b/lisp/emacs-lock.el
index 1553aeae0d5..9e0a93b4731 100644
--- a/lisp/emacs-lock.el
+++ b/lisp/emacs-lock.el
@@ -1,9 +1,10 @@
-;;; emacs-lock.el --- prevents you from exiting Emacs if a buffer is locked
+;;; emacs-lock.el --- protect buffers against killing or exiting -*- lexical-binding: t -*-
 
-;; Copyright (C) 1994, 1997, 2001-2011 Free Software Foundation, Inc
+;; Copyright (C) 2011 Free Software Foundation, Inc
 
-;; Author: Tom Wurgler <twurgler@goodyear.com>
-;; Created: 12/8/94
+;; Author: Juanma Barranquero <lekktu@gmail.com>
+;; Inspired by emacs-lock.el by Tom Wurgler <twurgler@goodyear.com>
+;; Maintainer: FSF
 ;; Keywords: extensions, processes
 
 ;; This file is part of GNU Emacs.
@@ -23,79 +24,217 @@
 
 ;;; Commentary:
 
-;; This code sets a buffer-local variable to t if toggle-emacs-lock is run,
-;; then if the user attempts to exit Emacs, the locked buffer name will be
-;; displayed and the exit aborted.  This is just a way of protecting
-;; yourself from yourself.  For example, if you have a shell running a big
-;; program and exiting Emacs would abort that program, you may want to lock
-;; that buffer, then if you forget about it after a while, you won't
-;; accidentally exit Emacs.  To unlock the buffer, just goto the buffer and
-;; run toggle-emacs-lock again.
+;; This package defines a minor mode Emacs Lock to mark a buffer as
+;; protected against accidental killing, or exiting Emacs, or both.
+;; Buffers associated with inferior modes, like shell or telnet, can
+;; be treated specially, by auto-unlocking them if their interior
+;; processes are dead.
 
 ;;; Code:
 
-(defvar emacs-lock-from-exiting nil
-  "Whether Emacs is locked to prevent exiting.  See `check-emacs-lock'.")
-(make-variable-buffer-local 'emacs-lock-from-exiting)
-
-(defvar emacs-lock-buffer-locked nil
-  "Whether a shell or telnet buffer was locked when its process was killed.")
-(make-variable-buffer-local 'emacs-lock-buffer-locked)
-(put 'emacs-lock-buffer-locked 'permanent-local t)
+(defgroup emacs-lock nil
+  "Emacs-Lock mode."
+  :version "24.1"
+  :group 'convenience)
+
+(defcustom emacs-lock-default-locking-mode 'all
+  "Default locking mode of Emacs-Locked buffers.
+
+Its value is used as the default for `emacs-lock-mode' (which
+see) the first time that Emacs Lock mode is turned on in a buffer
+without passing an explicit locking mode.
+
+Possible values are:
+ exit   -- Emacs cannot exit while the buffer is locked
+ kill   -- the buffer cannot be killed, but Emacs can exit as usual
+ all    -- the buffer is locked against both actions
+ nil    -- the buffer is not locked"
+  :type '(choice
+          (const :tag "Do not allow Emacs to exit" exit)
+          (const :tag "Do not allow killing the buffer" kill)
+          (const :tag "Do not allow killing the buffer or exiting Emacs" all)
+          (const :tag "Do not lock the buffer" nil))
+  :group 'emacs-lock
+  :version "24.1")
+
+;; Note: as auto-unlocking can lead to data loss, it would be better
+;; to default to nil; but the value below is for compatibility with
+;; the old emacs-lock.el.
+(defcustom emacs-lock-unlockable-modes '((shell-mode . all)
+                                         (telnet-mode . all))
+  "Alist of auto-unlockable modes.
+Each element is a pair (MAJOR-MODE . ACTION), where ACTION is
+one of `kill', `exit' or `all'.  Buffers with matching major
+modes are auto-unlocked for the specific action if their
+inferior processes are not alive.  If this variable is t, all
+buffers associated to inferior processes are auto-unlockable
+for both actions (NOT RECOMMENDED)."
+  :type '(choice
+          (const :tag "All buffers with inferior processes" t)
+          (repeat :tag "Selected modes"
+           (cons :tag "Set auto-unlock for"
+            (symbol :tag "Major mode")
+            (radio
+             (const :tag "Allow exiting" exit)
+             (const :tag "Allow killing" kill)
+             (const :tag "Allow both" all)))))
+  :group 'emacs-lock
+  :version "24.1")
+
+(defvar emacs-lock-mode nil
+  "If non-nil, the current buffer is locked.
+It can be one of the following values:
+ exit   -- Emacs cannot exit while the buffer is locked
+ kill   -- the buffer cannot be killed, but Emacs can exit as usual
+ all    -- the buffer is locked against both actions
+ nil    -- the buffer is not locked")
+(make-variable-buffer-local 'emacs-lock-mode)
+(put 'emacs-lock-mode 'permanent-local t)
+
+(defvar emacs-lock--old-mode nil
+  "Most recent locking mode set on the buffer.
+Internal use only.")
+(make-variable-buffer-local 'emacs-lock--old-mode)
+(put 'emacs-lock--old-mode 'permanent-local t)
+
+(defvar emacs-lock--try-unlocking nil
+  "Non-nil if current buffer should be checked for auto-unlocking.
+Internal use only.")
+(make-variable-buffer-local 'emacs-lock--try-unlocking)
+(put 'emacs-lock--try-unlocking 'permanent-local t)
+
+(defun emacs-lock-live-process-p (buffer-or-name)
+  "Return t if BUFFER-OR-NAME is associated with a live process."
+  (let ((proc (get-buffer-process buffer-or-name)))
+    (and proc (process-live-p proc))))
+
+(defun emacs-lock--can-auto-unlock (action)
+  "Return t if the current buffer can auto-unlock for ACTION.
+ACTION must be one of `kill' or `exit'.
+See `emacs-lock-unlockable-modes'."
+  (and emacs-lock--try-unlocking
+       (not (emacs-lock-live-process-p (current-buffer)))
+       (or (eq emacs-lock-unlockable-modes t)
+           (let ((unlock (cdr (assq major-mode emacs-lock-unlockable-modes))))
+             (or (eq unlock 'all) (eq unlock action))))))
+
+(defun emacs-lock--exit-locked-buffer ()
+  "Return the name of the first exit-locked buffer found."
+  (save-current-buffer
+    (catch :found
+      (dolist (buffer (buffer-list))
+        (set-buffer buffer)
+        (unless (or (emacs-lock--can-auto-unlock 'exit)
+                    (memq emacs-lock-mode '(nil kill)))
+          (throw :found (buffer-name))))
+      nil)))
+
+(defun emacs-lock--kill-emacs-hook ()
+  "Signal an error if any buffer is exit-locked.
+Used from `kill-emacs-hook' (which see)."
+  (let ((buffer-name (emacs-lock--exit-locked-buffer)))
+    (when buffer-name
+      (error "Emacs cannot exit because buffer %S is locked" buffer-name))))
+
+(defun emacs-lock--kill-emacs-query-functions ()
+  "Display a message if any buffer is exit-locked.
+Return a value appropriate for `kill-emacs-query-functions' (which see)."
+  (let ((locked (emacs-lock--exit-locked-buffer)))
+    (or (not locked)
+        (progn
+          (message "Emacs cannot exit because buffer %S is locked" locked)
+          nil))))
+
+(defun emacs-lock--kill-buffer-query-functions ()
+  "Display a message if the current buffer is kill-locked.
+Return a value appropriate for `kill-buffer-query-functions' (which see)."
+  (or (emacs-lock--can-auto-unlock 'kill)
+      (memq emacs-lock-mode '(nil exit))
+      (progn
+        (message "Buffer %S is locked and cannot be killed" (buffer-name))
+        nil)))
+
+(defun emacs-lock--set-mode (mode arg)
+  "Setter function for `emacs-lock-mode'."
+  (setq emacs-lock-mode
+        (cond ((memq arg '(all exit kill))
+               ;; explicit locking mode arg, use it
+               arg)
+              ((and (eq arg current-prefix-arg) (consp current-prefix-arg))
+               ;; called with C-u M-x emacs-lock-mode, so ask the user
+               (intern (completing-read "Locking mode: "
+                                        '("all" "exit" "kill")
+                                        nil t nil nil
+                                        (symbol-name
+                                         emacs-lock-default-locking-mode))))
+              ((eq mode t)
+               ;; turn on, so use previous setting, or customized default
+               (or emacs-lock--old-mode emacs-lock-default-locking-mode))
+              (t
+               ;; anything else (turn off)
+               mode))))
+
+;;;###autoload
+(define-minor-mode emacs-lock-mode
+    "Toggle Emacs Lock mode in the current buffer.
+
+With \\[universal-argument], ask for the locking mode to be used.
+With other prefix ARG, turn mode on if ARG is positive, off otherwise.
+
+Initially, if the user does not pass an explicit locking mode, it defaults
+to `emacs-lock-default-locking-mode' (which see); afterwards, the locking
+mode most recently set on the buffer is used instead.
+
+When called from Elisp code, ARG can be any locking mode:
+
+ exit   -- Emacs cannot exit while the buffer is locked
+ kill   -- the buffer cannot be killed, but Emacs can exit as usual
+ all    -- the buffer is locked against both actions
+
+Other values are interpreted as usual."
+  :init-value nil
+  :lighter (""
+            (emacs-lock--try-unlocking " locked:" " Locked:")
+            (:eval (symbol-name emacs-lock-model)))
+  :group 'emacs-lock
+  :variable (emacs-lock-mode .
+                             (lambda (mode)
+                               (emacs-lock--set-mode mode arg)))
+  (when emacs-lock-mode
+    (setq emacs-lock--old-mode emacs-lock-mode)
+    (setq emacs-lock--try-unlocking
+          (or (and (eq emacs-lock-unlockable-modes t)
+                   (emacs-lock-live-process-p (current-buffer)))
+              (assq major-mode emacs-lock-unlockable-modes)))))
 
-(defun check-emacs-lock ()
-  "Check if variable `emacs-lock-from-exiting' is t for any buffer.
-If any locked buffer is found, signal error and display the buffer's name."
-  (save-excursion
+(unless noninteractive
+  (add-hook 'kill-buffer-query-functions 'emacs-lock--kill-buffer-query-functions)
+  ;; We set a hook in both kill-emacs-hook and kill-emacs-query-functions because
+  ;; we really want to use k-e-q-f to stop as soon as possible, but don't want to
+  ;; be caught by surprise if someone calls `kill-emacs' instead.
+  (add-hook 'kill-emacs-hook 'emacs-lock--kill-emacs-hook)
+  (add-hook 'kill-emacs-query-functions 'emacs-lock--kill-emacs-query-functions))
+
+(defun emacs-lock-unload-function ()
+  "Unload the Emacs Lock library."
+  (catch :continue
     (dolist (buffer (buffer-list))
       (set-buffer buffer)
-      (when emacs-lock-from-exiting
-	(error "Emacs is locked from exit due to buffer: %s" (buffer-name))))))
+      (when emacs-lock-mode
+        (if (y-or-n-p (format "Buffer %S is locked, unlock it? " (buffer-name)))
+            (emacs-lock-mode -1)
+          (message "Unloading of feature `emacs-lock' aborted.")
+          (throw :continue t))))
+    ;; continue standard unloading
+    nil))
 
-(defun toggle-emacs-lock ()
-  "Toggle `emacs-lock-from-exiting' for the current buffer.
-See `check-emacs-lock'."
-  (interactive)
-  (setq emacs-lock-from-exiting (not emacs-lock-from-exiting))
-  (if emacs-lock-from-exiting
-      (message "Buffer is now locked")
-    (message "Buffer is now unlocked")))
-
-(defun emacs-lock-check-buffer-lock ()
-  "Check if variable `emacs-lock-from-exiting' is t for a buffer.
-If the buffer is locked, signal error and display its name."
-  (when emacs-lock-from-exiting
-    (error "Buffer `%s' is locked, can't delete it" (buffer-name))))
-
-; These next defuns make it so if you exit a shell that is locked,  the lock
-; is shut off for that shell so you can exit Emacs.  Same for telnet.
-; Also, if a shell or a telnet buffer was locked and the process killed,
-; turn the lock back on again if the process is restarted.
-
-(defun emacs-lock-shell-sentinel ()
-  (set-process-sentinel
-   (get-buffer-process (buffer-name)) (function emacs-lock-clear-sentinel)))
-
-(defun emacs-lock-clear-sentinel (_proc _str)
-  (if emacs-lock-from-exiting
-      (progn
-	(setq emacs-lock-from-exiting nil)
-	(setq emacs-lock-buffer-locked t)
-	(message "Buffer is now unlocked"))
-    (setq emacs-lock-buffer-locked nil)))
+;;; Compatibility
 
-(defun emacs-lock-was-buffer-locked ()
-  (if emacs-lock-buffer-locked
-      (setq emacs-lock-from-exiting t)))
+(define-obsolete-variable-alias 'emacs-lock-from-exiting 'emacs-lock-mode "24.1")
 
-(unless noninteractive
-  (add-hook 'kill-emacs-hook 'check-emacs-lock))
-(add-hook 'kill-buffer-hook 'emacs-lock-check-buffer-lock)
-(add-hook 'shell-mode-hook 'emacs-lock-was-buffer-locked)
-(add-hook 'shell-mode-hook 'emacs-lock-shell-sentinel)
-(add-hook 'telnet-mode-hook 'emacs-lock-was-buffer-locked)
-(add-hook 'telnet-mode-hook 'emacs-lock-shell-sentinel)
-
-(provide 'emacs-lock)
-
-;;; emacs-lock.el ends here
+(defun toggle-emacs-lock ()
+  "Toggle `emacs-lock-from-exiting' for the current buffer."
+  (interactive)
+  (call-interactively 'emacs-lock-mode))
+(make-obsolete 'toggle-emacs-lock 'emacs-lock-mode "24.1")
+k