lisp/emacs-lock.el

   1 ;;; emacs-lock.el --- protect buffers against killing or exiting -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2011-2018 Free Software Foundation, Inc.
   4
   5 ;; Author: Juanma Barranquero <lekktu@gmail.com>
   6 ;; Inspired by emacs-lock.el by Tom Wurgler <twurgler@goodyear.com>
   7 ;; Maintainer: emacs-devel@gnu.org
   8 ;; Keywords: extensions, processes
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;; This package defines a minor mode Emacs Lock to mark a buffer as
  28 ;; protected against accidental killing, or exiting Emacs, or both.
  29 ;; Buffers associated with inferior modes, like shell or telnet, can
  30 ;; be treated specially, by auto-unlocking them if their inferior
  31 ;; processes are dead.
  32
  33 ;;; Code:
  34
  35 (defgroup emacs-lock nil
  36   "Emacs-Lock mode."
  37   :version "24.1"
  38   :group 'convenience)
  39
  40 (defcustom emacs-lock-default-locking-mode 'all
  41   "Default locking mode of Emacs-Locked buffers.
  42
  43 Its value is used as the default for `emacs-lock-mode' (which
  44 see) the first time that Emacs Lock mode is turned on in a buffer
  45 without passing an explicit locking mode.
  46
  47 Possible values are:
  48  exit   -- Emacs cannot exit while the buffer is locked
  49  kill   -- the buffer cannot be killed, but Emacs can exit as usual
  50  all    -- the buffer is locked against both actions
  51  nil    -- the buffer is not locked"
  52   :type '(choice
  53           (const :tag "Do not allow Emacs to exit" exit)
  54           (const :tag "Do not allow killing the buffer" kill)
  55           (const :tag "Do not allow killing the buffer or exiting Emacs" all)
  56           (const :tag "Do not lock the buffer" nil))
  57   :group 'emacs-lock
  58   :version "24.1")
  59
  60 ;; Note: as auto-unlocking can lead to data loss, it would be better
  61 ;; to default to nil; but the value below is for compatibility with
  62 ;; the old emacs-lock.el.
  63 (defcustom emacs-lock-unlockable-modes '((shell-mode . all)
  64                                          (telnet-mode . all))
  65   "Alist of auto-unlockable modes.
  66 Each element is a pair (MAJOR-MODE . ACTION), where ACTION is
  67 one of `kill', `exit' or `all'.  Buffers with matching major
  68 modes are auto-unlocked for the specific action if their
  69 inferior processes are not alive.  If this variable is t, all
  70 buffers associated to inferior processes are auto-unlockable
  71 for both actions (NOT RECOMMENDED)."
  72   :type '(choice
  73           (const :tag "All buffers with inferior processes" t)
  74           (repeat :tag "Selected modes"
  75            (cons :tag "Set auto-unlock for"
  76             (symbol :tag "Major mode")
  77             (radio
  78              (const :tag "Allow exiting" exit)
  79              (const :tag "Allow killing" kill)
  80              (const :tag "Allow both" all)))))
  81   :group 'emacs-lock
  82   :version "24.1")
  83
  84 (defcustom emacs-lock-locked-buffer-functions nil
  85   "Abnormal hook run when Emacs Lock prevents exiting Emacs, or killing a buffer.
  86 The functions get one argument, the first locked buffer found."
  87   :type 'hook
  88   :group 'emacs-lock
  89   :version "24.3")
  90
  91 (define-obsolete-variable-alias 'emacs-lock-from-exiting
  92   'emacs-lock-mode "24.1")
  93
  94 (defvar-local emacs-lock-mode nil
  95   "If non-nil, the current buffer is locked.
  96 It can be one of the following values:
  97  exit   -- Emacs cannot exit while the buffer is locked
  98  kill   -- the buffer cannot be killed, but Emacs can exit as usual
  99  all    -- the buffer is locked against both actions
 100  nil    -- the buffer is not locked
 101
 102 See also `emacs-lock-unlockable-modes', which exempts buffers under
 103 some major modes from being locked under some circumstances.")
 104 (put 'emacs-lock-mode 'permanent-local t)
 105
 106 (defvar-local emacs-lock--old-mode nil
 107   "Most recent locking mode set on the buffer.
 108 Internal use only.")
 109 (put 'emacs-lock--old-mode 'permanent-local t)
 110
 111 (defvar-local emacs-lock--try-unlocking nil
 112   "Non-nil if current buffer should be checked for auto-unlocking.
 113 Internal use only.")
 114 (put 'emacs-lock--try-unlocking 'permanent-local t)
 115
 116 (defun emacs-lock-live-process-p (buffer-or-name)
 117   "Return t if BUFFER-OR-NAME is associated with a live process."
 118   (process-live-p (get-buffer-process buffer-or-name)))
 119
 120 (defun emacs-lock--can-auto-unlock (action)
 121   "Return t if the current buffer can auto-unlock for ACTION.
 122 ACTION must be one of `kill' or `exit'.
 123 See `emacs-lock-unlockable-modes'."
 124   (and emacs-lock--try-unlocking
 125        (not (emacs-lock-live-process-p (current-buffer)))
 126        (or (eq emacs-lock-unlockable-modes t)
 127            (let ((unlock (cdr (assq major-mode emacs-lock-unlockable-modes))))
 128              (or (eq unlock 'all) (eq unlock action))))))
 129
 130 (defun emacs-lock--exit-locked-buffer ()
 131   "Return the first exit-locked buffer found."
 132   (save-current-buffer
 133     (catch :found
 134       (dolist (buffer (buffer-list))
 135         (set-buffer buffer)
 136         (unless (or (emacs-lock--can-auto-unlock 'exit)
 137                     (memq emacs-lock-mode '(nil kill)))
 138           (throw :found buffer)))
 139       nil)))
 140
 141 (defun emacs-lock--kill-emacs-hook ()
 142   "Signal an error if any buffer is exit-locked.
 143 Used from `kill-emacs-hook' (which see)."
 144   (let ((locked (emacs-lock--exit-locked-buffer)))
 145     (when locked
 146       (run-hook-with-args 'emacs-lock-locked-buffer-functions locked)
 147       (error "Emacs cannot exit because buffer %S is locked"
 148              (buffer-name locked)))))
 149
 150 (defun emacs-lock--kill-emacs-query-functions ()
 151   "Display a message if any buffer is exit-locked.
 152 Return a value appropriate for `kill-emacs-query-functions' (which see)."
 153   (let ((locked (emacs-lock--exit-locked-buffer)))
 154     (if (not locked)
 155         t
 156       (run-hook-with-args 'emacs-lock-locked-buffer-functions locked)
 157       (message "Emacs cannot exit because buffer %S is locked"
 158                (buffer-name locked))
 159       nil)))
 160
 161 (defun emacs-lock--kill-buffer-query-functions ()
 162   "Display a message if the current buffer is kill-locked.
 163 Return a value appropriate for `kill-buffer-query-functions' (which see)."
 164   (if (or (emacs-lock--can-auto-unlock 'kill)
 165           (memq emacs-lock-mode '(nil exit)))
 166       t
 167     (run-hook-with-args 'emacs-lock-locked-buffer-functions (current-buffer))
 168     (message "Buffer %S is locked and cannot be killed" (buffer-name))
 169     nil))
 170
 171 (defun emacs-lock--set-mode (mode arg)
 172   "Setter function for `emacs-lock-mode'."
 173   (setq emacs-lock-mode
 174         (cond ((memq arg '(all exit kill))
 175                ;; explicit locking mode arg, use it
 176                arg)
 177               ((and (eq arg current-prefix-arg) (consp current-prefix-arg))
 178                ;; called with C-u M-x emacs-lock-mode, so ask the user
 179                (intern (completing-read "Locking mode: "
 180                                         '("all" "exit" "kill")
 181                                         nil t nil nil
 182                                         (symbol-name
 183                                          emacs-lock-default-locking-mode))))
 184               ((eq mode t)
 185                ;; turn on, so use previous setting, or customized default
 186                (or emacs-lock--old-mode emacs-lock-default-locking-mode))
 187               (t
 188                ;; anything else (turn off)
 189                mode))))
 190
 191 ;;;###autoload
 192 (define-minor-mode emacs-lock-mode
 193   "Toggle Emacs Lock mode in the current buffer.
 194 If called with a plain prefix argument, ask for the locking mode
 195 to be used.
 196
 197 Initially, if the user does not pass an explicit locking mode, it
 198 defaults to `emacs-lock-default-locking-mode' (which see);
 199 afterwards, the locking mode most recently set on the buffer is
 200 used instead.
 201
 202 When called from Elisp code, ARG can be any locking mode:
 203
 204  exit   -- Emacs cannot exit while the buffer is locked
 205  kill   -- the buffer cannot be killed, but Emacs can exit as usual
 206  all    -- the buffer is locked against both actions
 207
 208 Other values are interpreted as usual.
 209
 210 See also `emacs-lock-unlockable-modes', which exempts buffers under
 211 some major modes from being locked under some circumstances."
 212   :init-value nil
 213   :lighter (""
 214             (emacs-lock--try-unlocking " locked:" " Locked:")
 215             (:eval (symbol-name emacs-lock-mode)))
 216   :group 'emacs-lock
 217   :variable (emacs-lock-mode .
 218                              (lambda (mode)
 219                                (emacs-lock--set-mode mode arg)))
 220   (when emacs-lock-mode
 221     (setq emacs-lock--old-mode emacs-lock-mode)
 222     (setq emacs-lock--try-unlocking
 223           (and (if (eq emacs-lock-unlockable-modes t)
 224                    (emacs-lock-live-process-p (current-buffer))
 225                  (assq major-mode emacs-lock-unlockable-modes))
 226                t))))
 227
 228 (unless noninteractive
 229   (add-hook 'kill-buffer-query-functions 'emacs-lock--kill-buffer-query-functions)
 230   ;; We set a hook in both kill-emacs-hook and kill-emacs-query-functions because
 231   ;; we really want to use k-e-q-f to stop as soon as possible, but don't want to
 232   ;; be caught by surprise if someone calls `kill-emacs' instead.
 233   (add-hook 'kill-emacs-hook 'emacs-lock--kill-emacs-hook)
 234   (add-hook 'kill-emacs-query-functions 'emacs-lock--kill-emacs-query-functions))
 235
 236 (defun emacs-lock-unload-function ()
 237   "Unload the Emacs Lock library."
 238   (catch :continue
 239     (dolist (buffer (buffer-list))
 240       (set-buffer buffer)
 241       (when emacs-lock-mode
 242         (if (y-or-n-p (format "Buffer %S is locked, unlock it? " (buffer-name)))
 243             (emacs-lock-mode -1)
 244           (message "Unloading of feature `emacs-lock' aborted.")
 245           (throw :continue t))))
 246     ;; continue standard unloading
 247     nil))
 248
 249 ;;; Compatibility
 250
 251 (defun toggle-emacs-lock ()
 252   "Toggle `emacs-lock-from-exiting' for the current buffer."
 253   (declare (obsolete emacs-lock-mode "24.1"))
 254   (interactive)
 255   (call-interactively 'emacs-lock-mode))
 256
 257 (provide 'emacs-lock)
 258
 259 ;;; emacs-lock.el ends here