lisp/emacs-lock.el

   1 ;;; emacs-lock.el --- protect buffers against killing or exiting -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2011-2012 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: FSF
   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 <http://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 interior
  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 (defvar emacs-lock-mode nil
  92   "If non-nil, the current buffer is locked.
  93 It can be one of the following values:
  94  exit   -- Emacs cannot exit while the buffer is locked
  95  kill   -- the buffer cannot be killed, but Emacs can exit as usual
  96  all    -- the buffer is locked against both actions
  97  nil    -- the buffer is not locked")
  98 (make-variable-buffer-local 'emacs-lock-mode)
  99 (put 'emacs-lock-mode 'permanent-local t)
 100
 101 (defvar emacs-lock--old-mode nil
 102   "Most recent locking mode set on the buffer.
 103 Internal use only.")
 104 (make-variable-buffer-local 'emacs-lock--old-mode)
 105 (put 'emacs-lock--old-mode 'permanent-local t)
 106
 107 (defvar emacs-lock--try-unlocking nil
 108   "Non-nil if current buffer should be checked for auto-unlocking.
 109 Internal use only.")
 110 (make-variable-buffer-local 'emacs-lock--try-unlocking)
 111 (put 'emacs-lock--try-unlocking 'permanent-local t)
 112
 113 (defun emacs-lock-live-process-p (buffer-or-name)
 114   "Return t if BUFFER-OR-NAME is associated with a live process."
 115   (let ((proc (get-buffer-process buffer-or-name)))
 116     (and proc (process-live-p proc))))
 117
 118 (defun emacs-lock--can-auto-unlock (action)
 119   "Return t if the current buffer can auto-unlock for ACTION.
 120 ACTION must be one of `kill' or `exit'.
 121 See `emacs-lock-unlockable-modes'."
 122   (and emacs-lock--try-unlocking
 123        (not (emacs-lock-live-process-p (current-buffer)))
 124        (or (eq emacs-lock-unlockable-modes t)
 125            (let ((unlock (cdr (assq major-mode emacs-lock-unlockable-modes))))
 126              (or (eq unlock 'all) (eq unlock action))))))
 127
 128 (defun emacs-lock--exit-locked-buffer ()
 129   "Return the first exit-locked buffer found."
 130   (save-current-buffer
 131     (catch :found
 132       (dolist (buffer (buffer-list))
 133         (set-buffer buffer)
 134         (unless (or (emacs-lock--can-auto-unlock 'exit)
 135                     (memq emacs-lock-mode '(nil kill)))
 136           (throw :found buffer)))
 137       nil)))
 138
 139 (defun emacs-lock--kill-emacs-hook ()
 140   "Signal an error if any buffer is exit-locked.
 141 Used from `kill-emacs-hook' (which see)."
 142   (let ((locked (emacs-lock--exit-locked-buffer)))
 143     (when locked
 144       (run-hook-with-args 'emacs-lock-locked-buffer-functions locked)
 145       (error "Emacs cannot exit because buffer %S is locked"
 146              (buffer-name locked)))))
 147
 148 (defun emacs-lock--kill-emacs-query-functions ()
 149   "Display a message if any buffer is exit-locked.
 150 Return a value appropriate for `kill-emacs-query-functions' (which see)."
 151   (let ((locked (emacs-lock--exit-locked-buffer)))
 152     (if (not locked)
 153         t
 154       (run-hook-with-args 'emacs-lock-locked-buffer-functions locked)
 155       (message "Emacs cannot exit because buffer %S is locked"
 156                (buffer-name locked))
 157       nil)))
 158
 159 (defun emacs-lock--kill-buffer-query-functions ()
 160   "Display a message if the current buffer is kill-locked.
 161 Return a value appropriate for `kill-buffer-query-functions' (which see)."
 162   (if (or (emacs-lock--can-auto-unlock 'kill)
 163           (memq emacs-lock-mode '(nil exit)))
 164       t
 165     (run-hook-with-args 'emacs-lock-locked-buffer-functions (current-buffer))
 166     (message "Buffer %S is locked and cannot be killed" (buffer-name))
 167     nil))
 168
 169 (defun emacs-lock--set-mode (mode arg)
 170   "Setter function for `emacs-lock-mode'."
 171   (setq emacs-lock-mode
 172         (cond ((memq arg '(all exit kill))
 173                ;; explicit locking mode arg, use it
 174                arg)
 175               ((and (eq arg current-prefix-arg) (consp current-prefix-arg))
 176                ;; called with C-u M-x emacs-lock-mode, so ask the user
 177                (intern (completing-read "Locking mode: "
 178                                         '("all" "exit" "kill")
 179                                         nil t nil nil
 180                                         (symbol-name
 181                                          emacs-lock-default-locking-mode))))
 182               ((eq mode t)
 183                ;; turn on, so use previous setting, or customized default
 184                (or emacs-lock--old-mode emacs-lock-default-locking-mode))
 185               (t
 186                ;; anything else (turn off)
 187                mode))))
 188
 189 (define-obsolete-variable-alias 'emacs-lock-from-exiting
 190   'emacs-lock-mode "24.1")
 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.  With any other prefix ARG, turn mode on if ARG is
 196 positive, off otherwise.  If called from Lisp, enable the mode if
 197 ARG is omitted or nil.
 198
 199 Initially, if the user does not pass an explicit locking mode, it
 200 defaults to `emacs-lock-default-locking-mode' (which see);
 201 afterwards, the locking mode most recently set on the buffer is
 202 used instead.
 203
 204 When called from Elisp code, ARG can be any locking mode:
 205
 206  exit   -- Emacs cannot exit while the buffer is locked
 207  kill   -- the buffer cannot be killed, but Emacs can exit as usual
 208  all    -- the buffer is locked against both actions
 209
 210 Other values are interpreted as usual."
 211   :init-value nil
 212   :lighter (""
 213             (emacs-lock--try-unlocking " locked:" " Locked:")
 214             (:eval (symbol-name emacs-lock-mode)))
 215   :group 'emacs-lock
 216   :variable (emacs-lock-mode .
 217                              (lambda (mode)
 218                                (emacs-lock--set-mode mode arg)))
 219   (when emacs-lock-mode
 220     (setq emacs-lock--old-mode emacs-lock-mode)
 221     (setq emacs-lock--try-unlocking
 222           (and (if (eq emacs-lock-unlockable-modes t)
 223                    (emacs-lock-live-process-p (current-buffer))
 224                  (assq major-mode emacs-lock-unlockable-modes))
 225                t))))
 226
 227 (unless noninteractive
 228   (add-hook 'kill-buffer-query-functions 'emacs-lock--kill-buffer-query-functions)
 229   ;; We set a hook in both kill-emacs-hook and kill-emacs-query-functions because
 230   ;; we really want to use k-e-q-f to stop as soon as possible, but don't want to
 231   ;; be caught by surprise if someone calls `kill-emacs' instead.
 232   (add-hook 'kill-emacs-hook 'emacs-lock--kill-emacs-hook)
 233   (add-hook 'kill-emacs-query-functions 'emacs-lock--kill-emacs-query-functions))
 234
 235 (defun emacs-lock-unload-function ()
 236   "Unload the Emacs Lock library."
 237   (catch :continue
 238     (dolist (buffer (buffer-list))
 239       (set-buffer buffer)
 240       (when emacs-lock-mode
 241         (if (y-or-n-p (format "Buffer %S is locked, unlock it? " (buffer-name)))
 242             (emacs-lock-mode -1)
 243           (message "Unloading of feature `emacs-lock' aborted.")
 244           (throw :continue t))))
 245     ;; continue standard unloading
 246     nil))
 247
 248 ;;; Compatibility
 249
 250 (defun toggle-emacs-lock ()
 251   "Toggle `emacs-lock-from-exiting' for the current buffer."
 252   (interactive)
 253   (call-interactively 'emacs-lock-mode))
 254 (make-obsolete 'toggle-emacs-lock 'emacs-lock-mode "24.1")
 255
 256 (provide 'emacs-lock)
 257
 258 ;;; emacs-lock.el ends here