Function: todo-move-category

todo-move-category is an interactive and byte-compiled function defined in todo-mode.el.gz.

Signature

(todo-move-category)

Documentation

Move current category to a different todo file.

If the todo file chosen does not exist, it is created. If the current category has archived items, also move those to the archive of the file moved to, creating it if it does not exist.

Key Bindings

Source Code

;; Defined in /usr/src/emacs/lisp/calendar/todo-mode.el.gz
(defun todo-move-category ()
  "Move current category to a different todo file.
If the todo file chosen does not exist, it is created.
If the current category has archived items, also move those to
the archive of the file moved to, creating it if it does not exist."
  (interactive)
  (when (or (> (length todo-categories) 1)
	    (todo-y-or-n-p (concat "This is the only category in this file; "
				    "moving it will also delete the file.\n"
				    "Do you want to proceed? ")))
    (let* ((ofile todo-current-todo-file)
	   (cat (todo-current-category))
	   (nfile (todo-read-file-name "Todo file to move this category to: "))
	   (archive (concat (file-name-sans-extension ofile) ".toda"))
	   (buffers (append (list ofile)
			    (unless (zerop (todo-get-count 'archived cat))
			      (list archive))))
	   new)
      (while (equal nfile (file-truename ofile))
	(setq nfile (todo-read-file-name
		     "Choose a file distinct from this file: ")))
      (unless (member nfile todo-files)
	(with-current-buffer (get-buffer-create nfile)
	  (erase-buffer)
	  (write-region (point-min) (point-max) nfile nil 'nomessage nil t)
	  (kill-buffer nfile))
	(setq todo-files (funcall todo-files-function))
        (todo-update-filelist-defcustoms))
      (dolist (buf buffers)
        ;; Make sure archive file is in Todo Archive mode so that
        ;; todo-categories has correct value.
	(with-current-buffer (find-file-noselect buf)
          (when (equal (file-name-extension (buffer-file-name)) "toda")
            (unless (derived-mode-p 'todo-archive-mode)
              (todo-archive-mode)))
	  (widen)
	  (goto-char (point-max))
	  (let* ((beg (re-search-backward
		       (concat "^"
			       (regexp-quote (concat todo-category-beg cat))
			       "$")
		       nil t))
		 (end (if (re-search-forward
			   (concat "^" (regexp-quote todo-category-beg))
			   nil t 2)
			  (match-beginning 0)
			(point-max)))
		 (content (buffer-substring-no-properties beg end))
		 (counts (cdr (assoc cat todo-categories))))
	    ;; Restore display of selected category, so internal file
	    ;; structure is not visible if user is prompted to choose a new
	    ;; category name in target file.
	    (todo-category-select)
	    ;; Move the category to the new file.  Also update or create
	    ;; archive file if necessary.
	    (with-current-buffer
		(find-file-noselect
		 ;; Regenerate todo-archives in case there
		 ;; is a newly created archive.
		 (if (member buf (funcall todo-files-function t))
		     (concat (file-name-sans-extension nfile) ".toda")
		   nfile))
	      (if (equal (file-name-extension (buffer-file-name)) "toda")
		  (unless (derived-mode-p 'todo-archive-mode)
		    (todo-archive-mode))
		(unless (derived-mode-p 'todo-mode) (todo-mode)))
	      (let* ((nfile-short (todo-short-file-name nfile))
		     (prompt (concat
			      (format "Todo file \"%s\" already has "
				      nfile-short)
			      (format "the category \"%s\";\n" cat)
			      "enter a new category name: "))
		     (inhibit-read-only t)
		     (print-length nil)
		     (print-level nil))
		(widen)
		(goto-char (point-max))
		(insert content)
		;; If the file moved to has a category with the same
		;; name, rename the moved category.
		(when (assoc cat todo-categories)
		  (unless (member (file-truename (buffer-file-name))
				  (funcall todo-files-function t))
		    (setq new (read-from-minibuffer prompt))
		    (setq new (todo-validate-name new 'category))))
		;; Replace old with new name in todo and archive files.
		(when new
		  (goto-char (point-max))
		  (re-search-backward
		   (concat "^" (regexp-quote todo-category-beg)
			   "\\(" (regexp-quote cat) "\\)$")
                   nil t)
		  (replace-match new nil nil nil 1))
                (setq todo-categories
                      (append todo-categories (list (cons (or new cat) counts))))
                (goto-char (point-min))
                (if (looking-at "((\"")
                    ;; Delete existing sexp.
                    (delete-region (line-beginning-position) (line-end-position))
                  ;; Otherwise, file is new, so make space for categories sexp.
                  (insert "\n")
                  (goto-char (point-min)))
                ;; Insert (new or updated) sexp.
                (prin1 todo-categories (current-buffer)))
	      ;; If archive was just created, save it to avoid "File
	      ;; <xyz> no longer exists!" message on invoking
	      ;; `todo-find-archive'.
	      (unless (file-exists-p (buffer-file-name))
		(save-buffer))
	      (todo-category-number (or new cat))
	      (todo-category-select))
	    ;; Delete the category from the old file, and if that was the
	    ;; last category, delete the file.  Also handle archive file
	    ;; if necessary.
	    (let ((inhibit-read-only t))
	      (widen)
              (remove-overlays beg end)
	      (delete-region beg end)
	      (goto-char (point-min))
	      ;; Put point after todo-categories sexp.
	      (forward-line)
	      (if (eobp)		; Aside from sexp, file is empty.
		  (progn
		    ;; Skip confirming killing the archive buffer.
		    (set-buffer-modified-p nil)
		    (delete-file todo-current-todo-file)
		    (kill-buffer)
		    (when (member todo-current-todo-file todo-files)
                      (todo-update-filelist-defcustoms)))
		(setq todo-categories (delete (assoc cat todo-categories)
					      todo-categories))
		(todo-update-categories-sexp)
		(when (> todo-category-number (length todo-categories))
		  (setq todo-category-number 1))
		(todo-category-select))))))
      (set-window-buffer (selected-window)
			 (set-buffer (find-file-noselect nfile))))))