comparison lisp/desktop.el @ 81324:08f606738d5d

(desktop-load-locked-desktop): New option. (desktop-read): Use it. (desktop-truncate, desktop-outvar, desktop-restore-file-buffer): Use `when'.

81323:9afe4aab01d1

    (const :tag "Save if desktop file exists, else don't" if-exists)
    (const :tag "Never save" nil))
  :group 'desktop
  :version "22.1")

(defcustom desktop-base-file-name
  (convert-standard-filename ".emacs.desktop")
  "Name of file for Emacs desktop, excluding the directory part."
  :type 'file
  :group 'desktop)

;; ----------------------------------------------------------------------------
(defun desktop-truncate (list n)
  "Truncate LIST to at most N elements destructively."
  (let ((here (nthcdr (1- n) list)))
    (if (consp here)
	(setcdr here nil))))

;; ----------------------------------------------------------------------------
;;;###autoload
(defun desktop-clear ()
  "Empty the Desktop.

Furthermore, it clears the variables listed in `desktop-globals-to-clear'."
  (interactive)
  (desktop-lazy-abort)
  (dolist (var desktop-globals-to-clear)
    (if (symbolp var)
      (eval `(setq-default ,var nil))
      (eval `(setq-default ,(car var) ,(cdr var)))))
  (let ((buffers (buffer-list))
        (preserve-regexp (concat "^\\("
                                 (mapconcat (lambda (regexp)
                                              (concat "\\(" regexp "\\)"))

  "Convert VALUE to a pair (QUOTE . TXT); (eval (read TXT)) gives VALUE.
TXT is a string that when read and evaluated yields value.
QUOTE may be `may' (value may be quoted),
`must' (values must be quoted), or nil (value may not be quoted)."
  (cond
   ((or (numberp value) (null value) (eq t value) (keywordp value))
    (cons 'may (prin1-to-string value)))
   ((stringp value)
    (let ((copy (copy-sequence value)))
      (set-text-properties 0 (length copy) nil copy)
      ;; Get rid of text properties because we cannot read them
      (cons 'may (prin1-to-string copy))))
   ((symbolp value)
    (cons 'must (prin1-to-string value)))
   ((vectorp value)
    (let* ((special nil)
	   (pass1 (mapcar
		   (lambda (el)
		     (let ((res (desktop-internal-v2s el)))
		       (if (null (car res))
			   (setq special t))
		       res))
		   value)))
      (if special
	  (cons nil (concat "(vector "
			    (mapconcat (lambda (el)
					 (if (eq (car el) 'must)
					     (concat "'" (cdr el))
					   (cdr el)))
				       pass1
				       " ")
			    ")"))
	(cons 'may (concat "[" (mapconcat 'cdr pass1 " ") "]")))))
   ((consp value)
    (let ((p value)
	  newlist
	  use-list*
	  anynil)
      (while (consp p)
	(let ((q.txt (desktop-internal-v2s (car p))))
	  (or anynil (setq anynil (null (car q.txt))))
	  (setq newlist (cons q.txt newlist)))
	(setq p (cdr p)))
      (if p
	  (let ((last (desktop-internal-v2s p)))
	    (or anynil (setq anynil (null (car last))))
	    (or anynil
		(setq newlist (cons '(must . ".") newlist)))
	    (setq use-list* t)
	    (setq newlist (cons last newlist))))
      (setq newlist (nreverse newlist))
      (if anynil
	  (cons nil
		(concat (if use-list* "(desktop-list* "  "(list ")
			(mapconcat (lambda (el)
				     (if (eq (car el) 'must)
					 (concat "'" (cdr el))
				       (cdr el)))
				   newlist
				   " ")
			")"))
	(cons 'must
	      (concat "(" (mapconcat 'cdr newlist " ") ")")))))
   ((subrp value)
    (cons nil (concat "(symbol-function '"
		      (substring (prin1-to-string value) 7 -1)
		      ")")))
   ((markerp value)
    (let ((pos (prin1-to-string (marker-position value)))
	  (buf (prin1-to-string (buffer-name (marker-buffer value)))))
      (cons nil (concat "(let ((mk (make-marker)))"
			" (add-hook 'desktop-delay-hook"
			" (list 'lambda '() (list 'set-marker mk "
			pos " (get-buffer " buf ")))) mk)"))))
   (t					; save as text
    (cons 'may "\"Unprintable entity\""))))

;; ----------------------------------------------------------------------------
(defun desktop-value-to-string (value)
  "Convert VALUE to a string that when read evaluates to the same value.
Not all types of values are supported."

\(if the value is a list) before saving the value."
  (let (var size)
    (if (consp varspec)
	(setq var (car varspec) size (cdr varspec))
      (setq var varspec))
    (if (boundp var)
	(progn
	  (if (and (integerp size)
		   (> size 0)
		   (listp (eval var)))
	      (desktop-truncate (eval var) size))
	  (insert "(setq "
		  (symbol-name var)
		  " "
		  (desktop-value-to-string (symbol-value var))
		  ")\n")))))

;; ----------------------------------------------------------------------------
(defun desktop-save-buffer-p (filename bufname mode &rest dummy)
  "Return t if buffer should have its state saved in the desktop file.
FILENAME is the visited file name, BUFNAME is the buffer name, and

	      (desktop-buffer-fail-count 0)
	      (owner (desktop-owner))
	      ;; Avoid desktop saving during evaluation of desktop buffer.
	      (desktop-save nil))
	  (if (and owner
		   (not (y-or-n-p (format "Warning: desktop file appears to be in use by PID %s.\n\
Using it may cause conflicts.  Use it anyway? " owner))))
	      (progn (setq desktop-dirname nil)
		     (let ((default-directory desktop-dirname))
		       (run-hooks 'desktop-not-loaded-hook))
		     (message "Desktop file in use; not loaded."))
	    (desktop-lazy-abort)
	    ;; Evaluate desktop buffer and remember when it was modified.
	    (load (desktop-full-file-name) t t t)
	    (setq desktop-file-modtime (nth 5 (file-attributes (desktop-full-file-name))))
	    ;; If it wasn't already, mark it as in-use, to bother other

;; ----------------------------------------------------------------------------
(defun desktop-restore-file-buffer (desktop-buffer-file-name
                                    desktop-buffer-name
                                    desktop-buffer-misc)
  "Restore a file buffer."
  (if desktop-buffer-file-name
      (if (or (file-exists-p desktop-buffer-file-name)
              (let ((msg (format "Desktop: File \"%s\" no longer exists."
                                 desktop-buffer-file-name)))
                 (if desktop-missing-file-warning
		     (y-or-n-p (concat msg " Re-create buffer? "))
                   (message "%s" msg)
                   nil)))
	  (let* ((auto-insert nil) ; Disable auto insertion
		 (coding-system-for-read
		  (or coding-system-for-read
		      (cdr (assq 'buffer-file-coding-system
				 desktop-buffer-locals))))
		 (buf (find-file-noselect desktop-buffer-file-name)))
	    (condition-case nil
		(switch-to-buffer buf)
	      (error (pop-to-buffer buf)))
	    (and (not (eq major-mode desktop-buffer-major-mode))
		 (functionp desktop-buffer-major-mode)
		 (funcall desktop-buffer-major-mode))
	    buf)
	nil)))

(defun desktop-load-file (function)
  "Load the file where auto loaded FUNCTION is defined."
  (when function
    (let ((fcell (and (fboundp function) (symbol-function function))))

                ;; '(search-forward ...
                (eval desktop-buffer-point)
              (error (message "%s" (error-message-string err)) 1))))
        (when desktop-buffer-mark
          (if (consp desktop-buffer-mark)
            (progn
              (set-mark (car desktop-buffer-mark))
              (setq mark-active (car (cdr desktop-buffer-mark))))
            (set-mark desktop-buffer-mark)))
        ;; Never override file system if the file really is read-only marked.
        (if desktop-buffer-read-only (setq buffer-read-only desktop-buffer-read-only))
        (while desktop-buffer-locals
          (let ((this (car desktop-buffer-locals)))
            (if (consp this)
              ;; an entry of this form `(symbol . value)'
              (progn
                (make-local-variable (car this))
                (set (car this) (cdr this)))
              ;; an entry of the form `symbol'
              (make-local-variable this)
              (makunbound this)))
          (setq desktop-buffer-locals (cdr desktop-buffer-locals)))))))

81324:08f606738d5d

    (const :tag "Save if desktop file exists, else don't" if-exists)
    (const :tag "Never save" nil))
  :group 'desktop
  :version "22.1")

(defcustom desktop-load-locked-desktop 'ask
  "Specifies whether the desktop should be loaded if locked.
Possible values are:
   t    -- load anyway.
   nil  -- don't load.
   ask  -- ask the user.
If the value is nil, or `ask' and the user chooses not to load the desktop,
the normal hook `desktop-not-loaded-hook' is run."
  :type
  '(choice
    (const :tag "Load anyway" t)
    (const :tag "Don't load" nil)
    (const :tag "Ask the user" ask))
  :group 'desktop
  :version "23.1")

(defcustom desktop-base-file-name
  (convert-standard-filename ".emacs.desktop")
  "Name of file for Emacs desktop, excluding the directory part."
  :type 'file
  :group 'desktop)

;; ----------------------------------------------------------------------------
(defun desktop-truncate (list n)
  "Truncate LIST to at most N elements destructively."
  (let ((here (nthcdr (1- n) list)))
    (when (consp here)
      (setcdr here nil))))

;; ----------------------------------------------------------------------------
;;;###autoload
(defun desktop-clear ()
  "Empty the Desktop.

Furthermore, it clears the variables listed in `desktop-globals-to-clear'."
  (interactive)
  (desktop-lazy-abort)
  (dolist (var desktop-globals-to-clear)
    (if (symbolp var)
	(eval `(setq-default ,var nil))
      (eval `(setq-default ,(car var) ,(cdr var)))))
  (let ((buffers (buffer-list))
        (preserve-regexp (concat "^\\("
                                 (mapconcat (lambda (regexp)
                                              (concat "\\(" regexp "\\)"))

  "Convert VALUE to a pair (QUOTE . TXT); (eval (read TXT)) gives VALUE.
TXT is a string that when read and evaluated yields value.
QUOTE may be `may' (value may be quoted),
`must' (values must be quoted), or nil (value may not be quoted)."
  (cond
    ((or (numberp value) (null value) (eq t value) (keywordp value))
     (cons 'may (prin1-to-string value)))
    ((stringp value)
     (let ((copy (copy-sequence value)))
       (set-text-properties 0 (length copy) nil copy)
       ;; Get rid of text properties because we cannot read them
       (cons 'may (prin1-to-string copy))))
    ((symbolp value)
     (cons 'must (prin1-to-string value)))
    ((vectorp value)
     (let* ((special nil)
	    (pass1 (mapcar
		    (lambda (el)
		      (let ((res (desktop-internal-v2s el)))
			(if (null (car res))
			    (setq special t))
			res))
		    value)))
       (if special
	   (cons nil (concat "(vector "
			     (mapconcat (lambda (el)
					  (if (eq (car el) 'must)
					      (concat "'" (cdr el))
					    (cdr el)))
					pass1
					" ")
			     ")"))
	 (cons 'may (concat "[" (mapconcat 'cdr pass1 " ") "]")))))
    ((consp value)
     (let ((p value)
	   newlist
	   use-list*
	   anynil)
       (while (consp p)
	 (let ((q.txt (desktop-internal-v2s (car p))))
	   (or anynil (setq anynil (null (car q.txt))))
	   (setq newlist (cons q.txt newlist)))
	 (setq p (cdr p)))
       (if p
	   (let ((last (desktop-internal-v2s p)))
	     (or anynil (setq anynil (null (car last))))
	     (or anynil
		 (setq newlist (cons '(must . ".") newlist)))
	     (setq use-list* t)
	     (setq newlist (cons last newlist))))
       (setq newlist (nreverse newlist))
       (if anynil
	   (cons nil
		 (concat (if use-list* "(desktop-list* "  "(list ")
			 (mapconcat (lambda (el)
				      (if (eq (car el) 'must)
					  (concat "'" (cdr el))
					(cdr el)))
				    newlist
				    " ")
			 ")"))
	 (cons 'must
	       (concat "(" (mapconcat 'cdr newlist " ") ")")))))
    ((subrp value)
     (cons nil (concat "(symbol-function '"
		       (substring (prin1-to-string value) 7 -1)
		       ")")))
    ((markerp value)
     (let ((pos (prin1-to-string (marker-position value)))
	   (buf (prin1-to-string (buffer-name (marker-buffer value)))))
       (cons nil (concat "(let ((mk (make-marker)))"
			 " (add-hook 'desktop-delay-hook"
			 " (list 'lambda '() (list 'set-marker mk "
			 pos " (get-buffer " buf ")))) mk)"))))
    (t					 ; save as text
     (cons 'may "\"Unprintable entity\""))))

;; ----------------------------------------------------------------------------
(defun desktop-value-to-string (value)
  "Convert VALUE to a string that when read evaluates to the same value.
Not all types of values are supported."

\(if the value is a list) before saving the value."
  (let (var size)
    (if (consp varspec)
	(setq var (car varspec) size (cdr varspec))
      (setq var varspec))
    (when (boundp var)
      (when (and (integerp size)
		 (> size 0)
		 (listp (eval var)))
	(desktop-truncate (eval var) size))
      (insert "(setq "
	      (symbol-name var)
	      " "
	      (desktop-value-to-string (symbol-value var))
	      ")\n"))))

;; ----------------------------------------------------------------------------
(defun desktop-save-buffer-p (filename bufname mode &rest dummy)
  "Return t if buffer should have its state saved in the desktop file.
FILENAME is the visited file name, BUFNAME is the buffer name, and

	      (desktop-buffer-fail-count 0)
	      (owner (desktop-owner))
	      ;; Avoid desktop saving during evaluation of desktop buffer.
	      (desktop-save nil))
	  (if (and owner
		   (memq desktop-load-locked-desktop '(nil ask))
		   (or (null desktop-load-locked-desktop)
		       (not (y-or-n-p (format "Warning: desktop file appears to be in use by PID %s.\n\
Using it may cause conflicts.  Use it anyway? " owner)))))
	      (progn
		(setq desktop-dirname nil)
		(let ((default-directory desktop-dirname))
		  (run-hooks 'desktop-not-loaded-hook))
		(message "Desktop file in use; not loaded."))
	    (desktop-lazy-abort)
	    ;; Evaluate desktop buffer and remember when it was modified.
	    (load (desktop-full-file-name) t t t)
	    (setq desktop-file-modtime (nth 5 (file-attributes (desktop-full-file-name))))
	    ;; If it wasn't already, mark it as in-use, to bother other

;; ----------------------------------------------------------------------------
(defun desktop-restore-file-buffer (desktop-buffer-file-name
                                    desktop-buffer-name
                                    desktop-buffer-misc)
  "Restore a file buffer."
  (when desktop-buffer-file-name
    (if (or (file-exists-p desktop-buffer-file-name)
	    (let ((msg (format "Desktop: File \"%s\" no longer exists."
			       desktop-buffer-file-name)))
	      (if desktop-missing-file-warning
		  (y-or-n-p (concat msg " Re-create buffer? "))
		(message "%s" msg)
		nil)))
	(let* ((auto-insert nil) ; Disable auto insertion
	       (coding-system-for-read
		(or coding-system-for-read
		    (cdr (assq 'buffer-file-coding-system
			       desktop-buffer-locals))))
	       (buf (find-file-noselect desktop-buffer-file-name)))
	  (condition-case nil
	      (switch-to-buffer buf)
	    (error (pop-to-buffer buf)))
	  (and (not (eq major-mode desktop-buffer-major-mode))
	       (functionp desktop-buffer-major-mode)
	       (funcall desktop-buffer-major-mode))
	  buf)
      nil)))

(defun desktop-load-file (function)
  "Load the file where auto loaded FUNCTION is defined."
  (when function
    (let ((fcell (and (fboundp function) (symbol-function function))))

                ;; '(search-forward ...
                (eval desktop-buffer-point)
              (error (message "%s" (error-message-string err)) 1))))
        (when desktop-buffer-mark
          (if (consp desktop-buffer-mark)
	      (progn
		(set-mark (car desktop-buffer-mark))
		(setq mark-active (car (cdr desktop-buffer-mark))))
            (set-mark desktop-buffer-mark)))
        ;; Never override file system if the file really is read-only marked.
        (when desktop-buffer-read-only (setq buffer-read-only desktop-buffer-read-only))
        (while desktop-buffer-locals
          (let ((this (car desktop-buffer-locals)))
            (if (consp this)
		;; an entry of this form `(symbol . value)'
		(progn
		  (make-local-variable (car this))
		  (set (car this) (cdr this)))
              ;; an entry of the form `symbol'
              (make-local-variable this)
              (makunbound this)))
          (setq desktop-buffer-locals (cdr desktop-buffer-locals)))))))