emacs-lock.el 10 KB
Newer Older
1
;;; emacs-lock.el --- protect buffers against killing or exiting -*- lexical-binding: t -*-
Erik Naggum's avatar
Erik Naggum committed
2

Paul Eggert's avatar
Paul Eggert committed
3
;; Copyright (C) 2011-2020 Free Software Foundation, Inc.
Erik Naggum's avatar
Erik Naggum committed
4

5 6
;; Author: Juanma Barranquero <lekktu@gmail.com>
;; Inspired by emacs-lock.el by Tom Wurgler <twurgler@goodyear.com>
7
;; Maintainer: emacs-devel@gnu.org
Richard M. Stallman's avatar
Richard M. Stallman committed
8
;; Keywords: extensions, processes
Erik Naggum's avatar
Erik Naggum committed
9 10 11

;; This file is part of GNU Emacs.

12
;; GNU Emacs is free software: you can redistribute it and/or modify
Richard M. Stallman's avatar
Richard M. Stallman committed
13
;; it under the terms of the GNU General Public License as published by
14 15
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
Erik Naggum's avatar
Erik Naggum committed
16 17

;; GNU Emacs is distributed in the hope that it will be useful,
Richard M. Stallman's avatar
Richard M. Stallman committed
18 19 20
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
Erik Naggum's avatar
Erik Naggum committed
21

Richard M. Stallman's avatar
Richard M. Stallman committed
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/>.
Richard M. Stallman's avatar
Richard M. Stallman committed
24 25

;;; Commentary:
Erik Naggum's avatar
Erik Naggum committed
26

27 28 29
;; 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
30
;; be treated specially, by auto-unlocking them if their inferior
31
;; processes are dead.
Richard M. Stallman's avatar
Richard M. Stallman committed
32

Erik Naggum's avatar
Erik Naggum committed
33 34
;;; Code:

35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83
(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")

84 85 86 87 88
(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
89
  :version "24.3")
90

91 92 93
(define-obsolete-variable-alias 'emacs-lock-from-exiting
  'emacs-lock-mode "24.1")

94
(defvar-local emacs-lock-mode nil
95 96 97 98 99
  "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
100 101 102 103
 nil    -- the buffer is not locked

See also `emacs-lock-unlockable-modes', which exempts buffers under
some major modes from being locked under some circumstances.")
104 105
(put 'emacs-lock-mode 'permanent-local t)

106
(defvar-local emacs-lock--old-mode nil
107 108 109 110
  "Most recent locking mode set on the buffer.
Internal use only.")
(put 'emacs-lock--old-mode 'permanent-local t)

111
(defvar-local emacs-lock--try-unlocking nil
112 113 114 115 116 117
  "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."
118
  (and (process-live-p (get-buffer-process buffer-or-name)) t))
119 120 121 122 123 124 125 126 127 128 129 130

(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 ()
131
  "Return the first exit-locked buffer found."
132 133 134 135 136 137
  (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)))
138
          (throw :found buffer)))
139 140 141 142 143
      nil)))

(defun emacs-lock--kill-emacs-hook ()
  "Signal an error if any buffer is exit-locked.
Used from `kill-emacs-hook' (which see)."
144 145 146 147 148
  (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)))))
149 150 151 152 153

(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)))
154 155 156 157 158 159
    (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)))
160 161 162 163

(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)."
164 165 166 167 168 169
  (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))
170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192

(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
193 194
  "Toggle Emacs Lock mode in the current buffer.
If called with a plain prefix argument, ask for the locking mode
195
to be used.
196 197 198 199 200

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.
201 202 203 204 205 206 207

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

208 209 210 211
Other values are interpreted as usual.

See also `emacs-lock-unlockable-modes', which exempts buffers under
some major modes from being locked under some circumstances."
212 213 214
  :init-value nil
  :lighter (""
            (emacs-lock--try-unlocking " locked:" " Locked:")
215
            (:eval (symbol-name emacs-lock-mode)))
216 217 218 219 220 221 222
  :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
223 224 225 226
          (and (if (eq emacs-lock-unlockable-modes t)
                   (emacs-lock-live-process-p (current-buffer))
                 (assq major-mode emacs-lock-unlockable-modes))
               t))))
Richard M. Stallman's avatar
Richard M. Stallman committed
227

228 229 230 231 232 233 234 235 236 237 238
(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
239 240
    (dolist (buffer (buffer-list))
      (set-buffer buffer)
241 242 243 244 245 246 247
      (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))
Richard M. Stallman's avatar
Richard M. Stallman committed
248

249
;;; Compatibility
250

251 252
(defun toggle-emacs-lock ()
  "Toggle `emacs-lock-from-exiting' for the current buffer."
253
  (declare (obsolete emacs-lock-mode "24.1"))
254 255
  (interactive)
  (call-interactively 'emacs-lock-mode))
256 257 258 259

(provide 'emacs-lock)

;;; emacs-lock.el ends here