X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/49f70d46ea38ceb7a501594db7f6ea35e19681aa..2f67f8a145af8f185f644b1d094a03895a124ef1:/lisp/emacs-lock.el diff --git a/lisp/emacs-lock.el b/lisp/emacs-lock.el index 82b9655db2..28b8e35fba 100644 --- a/lisp/emacs-lock.el +++ b/lisp/emacs-lock.el @@ -1,10 +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, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 2011-2016 Free Software Foundation, Inc. -;; Author: Tom Wurgler -;; Created: 12/8/94 +;; Author: Juanma Barranquero +;; Inspired by emacs-lock.el by Tom Wurgler +;; Maintainer: emacs-devel@gnu.org ;; Keywords: extensions, processes ;; This file is part of GNU Emacs. @@ -24,79 +24,232 @@ ;;; 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 inferior +;; 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) - -(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 +(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") + +(defcustom emacs-lock-locked-buffer-functions nil + "Abnormal hook run when Emacs Lock prevents exiting Emacs, or killing a buffer. +The functions get one argument, the first locked buffer found." + :type 'hook + :group 'emacs-lock + :version "24.3") + +(defvar-local 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") +(put 'emacs-lock-mode 'permanent-local t) + +(defvar-local emacs-lock--old-mode nil + "Most recent locking mode set on the buffer. +Internal use only.") +(put 'emacs-lock--old-mode 'permanent-local t) + +(defvar-local emacs-lock--try-unlocking nil + "Non-nil if current buffer should be checked for auto-unlocking. +Internal use only.") +(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." + (process-live-p (get-buffer-process buffer-or-name))) + +(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 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))) + nil))) + +(defun emacs-lock--kill-emacs-hook () + "Signal an error if any buffer is exit-locked. +Used from `kill-emacs-hook' (which see)." + (let ((locked (emacs-lock--exit-locked-buffer))) + (when locked + (run-hook-with-args 'emacs-lock-locked-buffer-functions locked) + (error "Emacs cannot exit because buffer %S is locked" + (buffer-name locked))))) + +(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))) + (if (not locked) + t + (run-hook-with-args 'emacs-lock-locked-buffer-functions locked) + (message "Emacs cannot exit because buffer %S is locked" + (buffer-name 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)." + (if (or (emacs-lock--can-auto-unlock 'kill) + (memq emacs-lock-mode '(nil exit))) + t + (run-hook-with-args 'emacs-lock-locked-buffer-functions (current-buffer)) + (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)))) + +(define-obsolete-variable-alias 'emacs-lock-from-exiting + 'emacs-lock-mode "24.1") + +;;;###autoload +(define-minor-mode emacs-lock-mode + "Toggle Emacs Lock mode in the current buffer. +If called with a plain prefix argument, ask for the locking mode +to be used. With any other prefix ARG, turn mode on if ARG is +positive, off otherwise. If called from Lisp, enable the mode if +ARG is omitted or nil. + +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-mode))) + :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 + (and (if (eq emacs-lock-unlockable-modes t) + (emacs-lock-live-process-p (current-buffer)) + (assq major-mode emacs-lock-unlockable-modes)) + t)))) + +(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)) + +;;; Compatibility (defun toggle-emacs-lock () - "Toggle `emacs-lock-from-exiting' for the current buffer. -See `check-emacs-lock'." + "Toggle `emacs-lock-from-exiting' for the current buffer." + (declare (obsolete emacs-lock-mode "24.1")) (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))) - -(defun emacs-lock-was-buffer-locked () - (if emacs-lock-buffer-locked - (setq emacs-lock-from-exiting t))) - -(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) + (call-interactively 'emacs-lock-mode)) (provide 'emacs-lock) -;; arch-tag: 58e6cb43-7cf0-401a-bcb6-4902a0b8bdc1 ;;; emacs-lock.el ends here