Download
(require 'desktop)
(eval-when-compile (require 'cl))
(defgroup desktop-menu nil
"Managing multiple desktops."
:group 'desktop)
(defvar desktop-menu--kill-emacs-hooked-p nil
"Non-nil means we hooked into `kill-emacs-hook' to autosave current desktop.")
(defvar desktop-menu--autosave-timer nil
"Timer running the current-desktop autosave function.")
(defcustom desktop-menu-autosave nil
"Save the current desktop every this many seconds and on Emacs exit.
When set to a non-numeric true value, only save the desktop on Emacs exit.
If nil, don't autosave the current desktop."
:type '(choice (const :tag "Don't autosave" nil)
(number)
(other :tag "Only save on Emacs exit" t))
:set (lambda (sym val)
(and (boundp 'desktop-menu--autosave-timer)
desktop-menu--autosave-timer
(cancel-timer desktop-menu--autosave-timer))
(setq desktop-menu--autosave-timer
(and val
(numberp val)
(run-at-time val val 'desktop-menu--do-autosave)))
(if val (progn (add-hook 'kill-emacs-hook 'desktop-menu--do-autosave)
(setq desktop-menu--kill-emacs-hooked-p t))
(when desktop-menu--kill-emacs-hooked-p
(remove-hook 'kill-emacs-hook 'desktop-menu--do-autosave)
(setq desktop-menu--kill-emacs-hooked-p nil)))
(set-default sym val))
:group 'desktop-menu)
(defcustom desktop-menu-directory "~"
"Directory storing the desktop files."
:type 'directory
:group 'desktop-menu)
(defcustom desktop-menu-base-filename
(convert-standard-filename ".emacs.desktop")
"Base filename for different desktop files."
:type 'file
:group 'desktop-menu)
(defcustom desktop-menu-list-file
(convert-standard-filename ".emacs.desktops")
"File listing all the desktop files in a single directory."
:type 'file
:group 'desktop-menu)
(defcustom desktop-menu-mode-hook nil
"Hook run upon entering the *Desktop Menu*."
:type 'hook
:group 'desktop-menu)
(defcustom desktop-menu-clear 'ask
"Specifies the strategy for clearing the current desktop.
If nil, never clear the current desktop when loading another one.
If `ask', ask the user.
Any other non-nil value means clear the desktop unconditionally.
Desktop will be cleared by `desktop-clear'."
:type '(choice (const :tag "Ask user" ask)
(const :tag "Don't clear desktop" nil)
(other :tag "Always clear desktop" t))
:group 'desktop-menu)
(defcustom desktop-menu-ask-user-on-delete t
"If non-nil, ask user before deleting a desktop."
:group 'desktop-menu
:type 'boolean)
(defcustom desktop-menu-sort-p t
"If non-nil, sort desktops by name."
:group 'desktop-menu
:type 'boolean)
(defcustom desktop-menu-mode-font-lock-keywords
'(("\\(^ Desktops in directory\\) \\(.+\\)"
(1 font-lock-type-face append)
(1 'bold append)
(2 font-lock-function-name-face append))
("^. \\(.+?\\)\\([0-9]+ Buffer\\(s\\)?\\)"
(1 font-lock-function-name-face)
(2 font-lock-constant-face append)))
"Fontlock settings for Desktop Menu."
:type 'sexp
:group 'desktop-menu)
(defcustom desktop-menu-blist-mode-font-lock-keywords
'(("^\\(.+\\)|\\(.+\\)$"
(1 font-lock-type-face append)
(1 'bold append)
(2 font-lock-function-name-face append)))
"Fontlock settings for Desktop Buffer List."
:type 'sexp
:group 'desktop-menu)
(defvar desktop-menu--desktops nil
"List of all known desktops.")
(defvar desktop-menu--current-desktop nil
"Pair (cons cell) holding the name and filename of the current desktop.")
(defvar desktop-menu--blist-orig-layout nil
"Window configuration before opening Desktop Buffer List.")
(defvar desktop-menu--orig-layout nil
"Window configuration before starting Desktop Menu.")
(defvar desktop-menu-mode-map
(let ((map (make-sparse-keymap)))
(dotimes (i 10)
(define-key map (vector (+ ?0 i)) 'digit-argument))
(define-key map "\C-g" 'desktop-menu-abort)
(define-key map "\C-m" 'desktop-menu-load)
(define-key map "-" 'negative-argument)
(define-key map "?" 'desktop-menu-help)
(define-key map "^" 'desktop-menu-up-directory)
(define-key map "c" 'desktop-menu-change-directory)
(define-key map "d" 'desktop-menu-delete)
(define-key map "g" 'desktop-menu-refresh)
(define-key map "l" 'desktop-menu-list-desktop-buffers)
(define-key map "m" 'desktop-menu-merge)
(define-key map "n" 'desktop-menu-down)
(define-key map "o" 'desktop-menu-new)
(define-key map "p" 'desktop-menu-up)
(define-key map "q" 'desktop-menu-quit)
(define-key map "r" 'desktop-menu-rename)
(define-key map "s" 'desktop-menu-save)
(define-key map "v" 'desktop-menu-visit)
(define-key map "x" 'desktop-menu-clear)
(define-key map [down] 'desktop-menu-down)
(define-key map [up] 'desktop-menu-up)
map)
"Keymap for `desktop-menu-mode'.")
(defun desktop-menu--do-autosave ()
(when desktop-menu--current-desktop
(desktop-menu-save-into (cdr desktop-menu--current-desktop))))
(defun desktop-menu-mode ()
"Major mode for editing Emacs desktops.
\\<desktop-menu-mode-map>
Aside from the header line, each line describes one Emacs desktop
stored in `desktop-menu-directory'.
\\[desktop-menu-load] with the cursor on a desktop loads that desktop.
\\[desktop-menu-save] saves current desktop into the desktop under cursor.
\\[desktop-menu-quit] saves the desktop list and leaves *Desktop Menu*.
\\[desktop-menu-abort] aborts the menu without saving.
For faster navigation, use digit keys to supply a numeric argument directly.
Other keybindings:
\\[desktop-menu-help] - Display this help text.
\\[desktop-menu-up-directory] - Go up one directory.
\\[desktop-menu-change-directory] - Change to another directory.
\\[desktop-menu-delete] - Delete the current line's desktop.
\\[desktop-menu-refresh] - Refresh the listing.
\\[desktop-menu-list-desktop-buffers] - List the buffers saved in the current line's desktop.
\\[desktop-menu-merge] - Merge the current line's desktop into the current desktop.
\\[desktop-menu-new] - Create a new desktop.
\\[desktop-menu-rename] - Rename the current line's desktop.
\\[desktop-menu-visit] - View file storing the current line's desktop.
\\[desktop-menu-clear] - Clear the current Emacs desktop."
(kill-all-local-variables)
(use-local-map desktop-menu-mode-map)
(setq buffer-read-only t
font-lock-defaults '(desktop-menu-mode-font-lock-keywords t)
font-lock-verbose nil
major-mode 'desktop-menu-mode
mode-name "Desktop Menu"
truncate-lines t)
(run-mode-hooks 'desktop-menu-mode-hook))
(defun desktop-menu-save-main-list (desktops directory)
"Save DESKTOPS in DIRECTORY into `desktop-menu-list-file'."
(unless (file-exists-p desktop-menu-directory)
(make-directory desktop-menu-directory))
(let ((mainfile (expand-file-name desktop-menu-list-file directory)))
(find-file mainfile)
(erase-buffer)
(insert "
"
(expand-file-name "." directory) "\n"
"
" (current-time-string) "\n"
" emacs-version "\n\n"
"(setq desktop-menu--desktops\n"
" (list\n")
(while desktops
(insert (format " '(%S %S)\n"
(caar desktops)
(cadar desktops)))
(setq desktops (cdr desktops)))
(insert " ))\n")
(save-buffer)
(kill-buffer (current-buffer))))
(defun desktop-menu-read-main-list (directory)
"Read list of desktops from `desktop-menu-list-file' in DIRECTORY.
Return a list of desktops."
(let (desktop-menu--desktops
desktops
(mainfile (expand-file-name desktop-menu-list-file directory)))
(if (file-exists-p mainfile)
(save-window-excursion
(save-excursion
(load-file mainfile))))
(setq desktops desktop-menu--desktops)
(let ((list (copy-sequence desktop-menu--desktops)))
(while list
(if (not (file-exists-p (expand-file-name (cadar list) directory)))
(setq desktops
(remove (car list) desktops)))
(setq list (cdr list))))
(let* ((base desktop-menu-base-filename)
(existing-in-main (mapcar 'cadr desktops))
(all (directory-files directory
nil
(concat (regexp-quote base)
"[0-9]*$"))))
(while all
(if (not (member (car all) existing-in-main))
(setq desktops
(append desktops
(list (list (if (string= (car all) base)
"Default"
"No Name")
(car all))))))
(setq all (cdr all))))
(if desktop-menu-sort-p
(sort desktops
(function (lambda (e1 e2)
(string< (car e1) (car e2)))))
desktops)))
(defun desktop-menu-list (directory &optional read-main-p)
"List all desktops in DIRECTORY in a *Desktop Menu* buffer.
With optional argument READ-MAIN-P non-nil, read the file
`desktop-menu-list-file' for the desktop list."
(unless (file-readable-p directory)
(error "%S is not a valid directory" directory))
(switch-to-buffer (get-buffer-create "*Desktop Menu*"))
(cd directory)
(setq desktop-menu-directory directory)
(when read-main-p
(setq desktop-menu--desktops
(desktop-menu-read-main-list directory)))
(desktop-menu-mode)
(let ((inhibit-read-only t)
(desktops desktop-menu--desktops))
(erase-buffer)
(insert " Desktops in directory "
(expand-file-name "." desktop-menu-directory)
"\n")
(while desktops
(let* ((desktop (car desktops))
(name (car desktop))
(fname (cadr desktop)))
(insert (if (string= name (car desktop-menu--current-desktop))
"."
" ")
(format " %-30s %20s %s"
name
(desktop-menu-extra-desktop-description fname)
fname))
(newline))
(setq desktops (cdr desktops)))
(backward-delete-char 1)
(beginning-of-line)
(set-buffer-modified-p nil)
(font-lock-fontify-buffer)
(desktop-menu--set-window-height)
(goto-char (point-min))
(when (and (not (search-forward-regexp "^\\." nil t))
(not (eq (line-end-position) (point-max))))
(forward-line 1))
(beginning-of-line)))
(defun desktop-menu-new-file (directory)
"Create a name for a new file in DIRECTORY."
(let ((n -1)
(filenames (mapcar 'cadr desktop-menu--desktops))
filename)
(while (not filename)
(setq n (1+ n))
(let ((relative-filename (concat desktop-menu-base-filename
(if (eq 0 n) "" (int-to-string n)))))
(setq filename
(and (not (file-exists-p (expand-file-name relative-filename
directory)))
(not (member relative-filename filenames))
relative-filename))))
filename))
(defun desktop-menu-line-desktop ()
"Return the current line's desktop."
(let ((line (1- (count-lines (point-min) (if (eobp) (point) (1+ (point)))))))
(if (and (>= line 1)
(<= line (length desktop-menu--desktops)))
(nth (1- line) desktop-menu--desktops)
(error "You are not on a desktop line"))))
(defun desktop-menu--set-window-height ()
"Change height of the selected window to suit the desktop list."
(unless (one-window-p t)
(shrink-window (- (window-height (selected-window))
(+ 2 (max 4 (length desktop-menu--desktops)))))))
(defun desktop-menu-extra-desktop-description (filename)
"Return a desktop description string.
The string contains some information about the desktop saved in FILENAME."
(let ((file (expand-file-name filename desktop-menu-directory)))
(if (file-exists-p file)
(with-temp-buffer
(insert-file-contents file)
(goto-char (point-min))
(let ((time (if (search-forward-regexp "^ nil t)
(match-string 1)
""))
(count 0))
(while (search-forward-regexp "^(desktop-create-buffer" nil t)
(setq count (1+ count)))
(format "%2d %s %s"
count (if (= count 1) "Buffer" "Buffers") time)))
"empty")))
(defun desktop-menu-up (arg)
"Move cursor up ARG lines in Desktop Menu."
(interactive "p")
(if (> 0 arg)
(desktop-menu-down (- arg))
(let ((arg (mod arg (length desktop-menu--desktops)))
(lines (count-lines (point-min) (point))))
(if (>= arg lines)
(desktop-menu-down (- (count-lines (point-min) (point-max))
(1+ arg)))
(previous-line arg)))))
(defun desktop-menu-down (arg)
"Move cursor down ARG lines in Desktop Menu."
(interactive "p")
(when (eq 0 (count-lines (point-min) (point)))
(progn (next-line 1)
(setq arg (1- arg))))
(if (> 0 arg)
(desktop-menu-up (- arg))
(let ((arg (mod arg (length desktop-menu--desktops)))
(lines (count-lines (point) (point-max))))
(if (>= arg lines)
(desktop-menu-up (- (count-lines (point-min) (point-max)) arg 1))
(next-line arg)))))
(defun desktop-menu-new (name)
"Create a new desktop with name NAME."
(interactive "sName of the new desktop: ")
(setq desktop-menu--desktops
(append desktop-menu--desktops
(list (list name
(desktop-menu-new-file desktop-menu-directory)))))
(desktop-menu-list desktop-menu-directory)
(message "Now you can save the newly created desktop"))
(defun desktop-menu-refresh ()
"Refresh Desktop Menu."
(interactive)
(desktop-menu-list desktop-menu-directory))
(defun desktop-menu-change-directory (directory)
"Change to the desktop list in directory DIRECTORY."
(interactive "DChange to directory: ")
(unless (file-readable-p directory)
(error "%S is not a valid directory" directory))
(desktop-menu-save-main-list desktop-menu--desktops
desktop-menu-directory)
(setq desktop-menu-directory directory
default-directory directory)
(desktop-menu-list desktop-menu-directory t))
(defun desktop-menu-up-directory ()
"Switch to the parent directory of `desktop-menu-directory'."
(interactive)
(desktop-menu-change-directory
(file-name-directory (directory-file-name desktop-menu-directory))))
(defun desktop-menu-rename (name)
"Rename the current line's desktop to NAME."
(interactive "sNew name: ")
(setcar (desktop-menu-line-desktop) name)
(desktop-menu-list desktop-menu-directory))
(defun desktop-menu-quit ()
"Leave Desktop Menu and save current desktop list."
(interactive)
(bury-buffer)
(desktop-menu-save-main-list desktop-menu--desktops
desktop-menu-directory)
(set-window-configuration desktop-menu--orig-layout))
(defun desktop-menu-abort ()
"Ding and leave Desktop Menu without saving current desktop list."
(interactive)
(ding)
(bury-buffer)
(set-window-configuration desktop-menu--orig-layout))
(defun desktop-menu-clear ()
"Clear the current desktop with `desktop-clear'."
(interactive)
(let ((desktop-clear-preserve-buffers
(cons "*Desktop Menu*" desktop-clear-preserve-buffers)))
(desktop-clear)
(set-window-configuration desktop-menu--orig-layout)))
(defun desktop-menu-visit ()
"Exit Desktop Menu and visit file storing the desktop under cursor."
(interactive)
(let ((desktop (desktop-menu-line-desktop)))
(desktop-menu-quit)
(find-file-read-only (expand-file-name (cadr desktop)
desktop-menu-directory))))
(defun desktop-menu-load (&optional clearp)
"Load the current line's desktop.
See the variable `desktop-menu-clear' for the meaning and
possible values of the CLEARP parameter."
(interactive)
(let* ((desktop-clear-preserve-buffers
(cons "*Desktop Menu*" desktop-clear-preserve-buffers))
(desktop (desktop-menu-line-desktop))
(name (car desktop))
(fname (expand-file-name (cadr desktop) desktop-menu-directory)))
(setq clearp (or clearp desktop-menu-clear))
(when (or (and (eq clearp 'ask)
(y-or-n-p "Clear desktop? "))
clearp)
(desktop-clear))
(set-window-configuration desktop-menu--orig-layout)
(desktop-menu-read fname)
(setq desktop-menu--current-desktop (cons name fname))))
(defun desktop-menu-delete ()
"Delete the current line's desktop.
Honours the `desktop-menu-ask-user-on-delete' variable setting."
(interactive)
(let* ((desktop (desktop-menu-line-desktop))
(name (car desktop))
(fname (cadr desktop)))
(when (or (not desktop-menu-ask-user-on-delete)
(y-or-n-p (format "Delete Desktop %S? " name)))
(when (file-exists-p fname)
(delete-file fname))
(setq desktop-menu--desktops
(remove desktop
desktop-menu--desktops))
(desktop-menu-list desktop-menu-directory))))
(defun desktop-menu-merge ()
"Load the current line's desktop
(interactive)
(desktop-menu-load))
(defun desktop-menu-save ()
"Save the current desktop into the current line's desktop file."
(interactive)
(let* ((desktop (desktop-menu-line-desktop))
(name (car desktop))
(fname (expand-file-name (cadr desktop) desktop-menu-directory)))
(desktop-menu-save-into fname)
(setq desktop-menu--current-desktop (cons name fname))
(desktop-menu-list desktop-menu-directory)
(message "Saved into desktop %s" name)))
(defun desktop-menu-help ()
"Help for `desktop-menu-mode'."
(interactive)
(describe-function 'desktop-menu-mode))
(defvar desktop-menu-blist-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "l" 'desktop-menu-blist-lift)
(define-key map "n" 'next-line)
(define-key map "p" 'previous-line)
(define-key map "q" 'desktop-menu-blist-quit)
map)
"Keymap for *Desktop Buffer List*.")
'(defun desktop-menu-blist-lift (&optional arg)
"Recreate the buffer at point in the current session.
With a prefix argument, also remove it from its original desktop."
(interactive "P")
(let ((bname (progn (beginning-of-line)
(looking-at ))))
(eval (catch 'found
(with-temp-buffer
(insert-file-contents desktop-menu-blist-desktop-file)
(while (search-forward "(desktop-create-buffer" nil t)
(beginning-of-line)
(let* ((buf (read (current-buffer))))
(and (string= (nth 3 buf) bname)
(throw 'found buf)))))))))
(defun desktop-menu-blist-quit ()
(interactive)
(kill-buffer nil)
(set-window-configuration desktop-menu--blist-orig-layout))
(defvar desktop-menu-blist-desktop-file nil
"Name of the file containing definition of the currently listed desktop.")
(put 'desktop-menu-blist-desktop-file 'permanent-local t)
(define-derived-mode desktop-menu-blist-mode special-mode "Desktop Buffer List"
(setq font-lock-defaults '(desktop-menu-blist-mode-font-lock-keywords t)))
(defvar desktop-first-buffer)
(defvar desktop-buffer-ok-count)
(defvar desktop-buffer-fail-count)
(defun desktop-menu-list-desktop-buffers ()
"List buffers saved in the current line's desktop."
(interactive)
(let* (blist
(desktop (desktop-menu-line-desktop))
(desktop-file (cadr desktop)))
(with-temp-buffer
(insert-file-contents desktop-file)
(while (search-forward "(desktop-create-buffer" nil t)
(beginning-of-line)
(let* ((buf (read (current-buffer)))
(entry
(if (nth 2 buf)
(cons (nth 3 buf) (abbreviate-file-name (nth 2 buf)))
(case (cadr (nth 4 buf))
(dired-mode
(cons (nth 3 buf)
(abbreviate-file-name (caadr (nth 9 buf)))))
(Info-mode
(cons
(nth 3 buf)
(concat "("
(file-name-nondirectory
(or (caadr (nth 9 buf)) "No file"))
") "
(cadadr (nth 9 buf)))))
(w3m-mode (cons (nth 3 buf) (nth 9 buf)))))))
(and entry (push entry blist)))))
(setq desktop-menu--blist-orig-layout (current-window-configuration))
(switch-to-buffer-other-window (get-buffer-create "*Desktop Buffer List*"))
(let ((inhibit-read-only t))
(mapc (lambda (c)
(insert (car c) " |" (cdr c) "\n"))
(sort blist (lambda (x y) (string< (car x) (car y)))))
(align-regexp (point-min) (point-max) "\\( \\)|" 1 0))
(desktop-menu-blist-mode)))
(defun desktop-menu-save-into (filename)
"Save the current desktop into FILENAME."
(interactive "F")
(let ((desktop-base-file-name (file-name-nondirectory filename)))
(desktop-save (file-name-directory filename))))
(defun desktop-menu-read (filename)
"Load desktop of FILENAME."
(interactive "F")
(let ((desktop-dirname (file-name-directory filename))
(desktop-base-file-name (file-name-nondirectory filename)))
(message (format "File: %S Desktop dir: %S"
desktop-base-file-name
desktop-dirname))
(desktop-read desktop-dirname)))
(defun desktop-menu-in (directory)
"Make a menu of available desktops in directory DIRECTORY."
(interactive "D")
(setq desktop-menu--orig-layout (current-window-configuration))
(let ((active-desktop-window nil))
(walk-windows (function (lambda (window)
(if (string= (buffer-name (window-buffer window))
"*Desktop Menu*")
(setq active-desktop-window window)))))
(if active-desktop-window
(select-window active-desktop-window)
(when (> (window-height (selected-window)) 7)
(split-window (selected-window)))
(other-window 1)))
(desktop-menu-list directory t))
(defun desktop-menu ()
"Make a menu of available Emacs desktops in `desktop-menu-directory'."
(interactive)
(desktop-menu-in desktop-menu-directory))
(provide 'desktop-menu)