diff --git a/lisp/org-agenda.el b/lisp/org-agenda.el index 87dcf5d94..7b35508d8 100644 --- a/lisp/org-agenda.el +++ b/lisp/org-agenda.el @@ -9745,178 +9745,191 @@ bulk action." "Execute an remote-editing action on all marked entries. The prefix arg is passed through to the command if possible." (interactive "P") - ;; Make sure we have markers, and only valid ones + ;; Make sure we have markers, and only valid ones. (unless org-agenda-bulk-marked-entries (user-error "No entries are marked")) - (mapc - (lambda (m) - (unless (and (markerp m) - (marker-buffer m) - (buffer-live-p (marker-buffer m)) - (marker-position m)) - (user-error "Marker %s for bulk command is invalid" m))) - org-agenda-bulk-marked-entries) + (dolist (m org-agenda-bulk-marked-entries) + (unless (and (markerp m) + (marker-buffer m) + (buffer-live-p (marker-buffer m)) + (marker-position m)) + (user-error "Marker %s for bulk command is invalid" m))) - ;; Prompt for the bulk command - (let* ((msg (if org-agenda-persistent-marks "Bulk (persistent): " "Bulk: "))) - (message (concat msg "[$]arch [A]rch->sib [t]odo [+/-]tag [s]chd [d]eadline [r]efile " - "[S]catter [f]unction " - (when org-agenda-bulk-custom-functions - (concat " Custom: [" - (mapconcat (lambda(f) (char-to-string (car f))) - org-agenda-bulk-custom-functions "") - "]")))) - (catch 'exit - (let* ((action (read-char-exclusive)) - (org-log-refile (if org-log-refile 'time nil)) - (entries (reverse org-agenda-bulk-marked-entries)) - (org-overriding-default-time - (if (get-text-property (point) 'org-agenda-date-header) - (org-get-cursor-date))) - redo-at-end - cmd rfloc state e tag pos (cnt 0) (cntskip 0)) - (cond - ((equal action ?p) - (let ((org-agenda-persistent-marks - (not org-agenda-persistent-marks))) - (org-agenda-bulk-action) - (throw 'exit nil))) + ;; Prompt for the bulk command. + (message + (concat (if org-agenda-persistent-marks "Bulk (persistent): " "Bulk: ") + "[$]arch [A]rch->sib [t]odo [+/-]tag [s]chd [d]eadline [r]efile " + "[S]catter [f]unction " + (and org-agenda-bulk-custom-functions + (format " Custom: [%s]" + (mapconcat (lambda (f) (char-to-string (car f))) + org-agenda-bulk-custom-functions + ""))))) + (catch 'exit + (let* ((org-log-refile (if org-log-refile 'time nil)) + (entries (reverse org-agenda-bulk-marked-entries)) + (org-overriding-default-time + (and (get-text-property (point) 'org-agenda-date-header) + (org-get-cursor-date))) + redo-at-end + cmd) + (pcase (read-char-exclusive) + (?p + (let ((org-agenda-persistent-marks + (not org-agenda-persistent-marks))) + (org-agenda-bulk-action) + (throw 'exit nil))) - ((equal action ?$) - (setq cmd '(org-agenda-archive))) + (?$ + (setq cmd #'org-agenda-archive)) - ((equal action ?A) - (setq cmd '(org-agenda-archive-to-archive-sibling))) + (?A + (setq cmd #'org-agenda-archive-to-archive-sibling)) - ((member action '(?r ?w)) - (setq rfloc (org-refile-get-location - "Refile to" - (marker-buffer (car entries)) - org-refile-allow-creating-parent-nodes)) - (if (nth 3 rfloc) - (setcar (nthcdr 3 rfloc) - (move-marker (make-marker) (nth 3 rfloc) - (or (get-file-buffer (nth 1 rfloc)) - (find-buffer-visiting (nth 1 rfloc)) - (error "This should not happen"))))) + ((or ?r ?w) + (let ((refile-location + (org-refile-get-location + "Refile to" + (marker-buffer (car entries)) + org-refile-allow-creating-parent-nodes))) + (when (nth 3 refile-location) + (setcar (nthcdr 3 refile-location) + (move-marker + (make-marker) + (nth 3 refile-location) + (or (get-file-buffer (nth 1 refile-location)) + (find-buffer-visiting (nth 1 refile-location)) + (error "This should not happen"))))) - (setq cmd (list 'org-agenda-refile nil (list 'quote rfloc) t) - redo-at-end t)) + (setq cmd `(lambda () (org-agenda-refile nil ',refile-location t))) + (setq redo-at-end t))) - ((equal action ?t) - (setq state (completing-read + (?t + (let ((state (completing-read "Todo state: " (with-current-buffer (marker-buffer (car entries)) - (mapcar #'list org-todo-keywords-1)))) - (setq cmd `(let ((org-inhibit-blocking t) - (org-inhibit-logging 'note)) - (org-agenda-todo ,state)))) + (mapcar #'list org-todo-keywords-1))))) + (setq cmd `(lambda () + (let ((org-inhibit-blocking t) + (org-inhibit-logging 'note)) + (org-agenda-todo ,state)))))) - ((memq action '(?- ?+)) - (setq tag (completing-read + ((and (or ?- ?+) action) + (let ((tag (completing-read (format "Tag to %s: " (if (eq action ?+) "add" "remove")) (with-current-buffer (marker-buffer (car entries)) (delq nil (mapcar (lambda (x) (and (stringp (car x)) x)) - org-current-tag-alist))))) - (setq cmd `(org-agenda-set-tags ,tag ,(if (eq action ?+) ''on ''off)))) + org-current-tag-alist)))))) + (setq cmd + `(lambda () + (org-agenda-set-tags ,tag + ,(if (eq action ?+) ''on ''off)))))) - ((memq action '(?s ?d)) - (let* ((time - (unless arg - (org-read-date - nil nil nil - (if (eq action ?s) "(Re)Schedule to" "(Re)Set Deadline to") - org-overriding-default-time))) - (c1 (if (eq action ?s) 'org-agenda-schedule - 'org-agenda-deadline))) - ;; Make sure to not prompt for a note when bulk - ;; rescheduling as Org cannot cope with simultaneous - ;; notes. Besides, it could be annoying depending on the - ;; number of items re-scheduled. - (setq cmd `(eval '(let ((org-log-reschedule - (and org-log-reschedule 'time)) - (org-log-redeadline - (and org-log-redeadline 'time))) - (,c1 arg ,time)))))) + (?s + (let ((time + (or arg + (org-read-date nil nil nil "(Re)Schedule to" + org-overriding-default-time)))) + ;; Make sure to not prompt for a note when bulk + ;; rescheduling as Org cannot cope with simultaneous notes. + ;; Besides, it could be annoying depending on the number of + ;; items re-scheduled. + (setq cmd + `(lambda () + (let ((org-log-reschedule (and org-log-reschedule 'time))) + (org-agenda-schedule arg ,time)))))) + (?d + (let ((time + (or arg + (org-read-date nil nil nil "(Re)Set Deadline to" + org-overriding-default-time)))) + ;; Make sure to not prompt for a note when bulk + ;; rescheduling as Org cannot cope with simultaneous + ;; notes. Besides, it could be annoying depending on the + ;; number of items re-scheduled. + (setq cmd + `(lambda () + (let ((org-log-redeadline (and org-log-redeadline 'time))) + (org-agenda-deadline arg ,time)))))) - ((equal action ?S) - (if (not (org-agenda-check-type nil 'agenda 'timeline 'todo)) - (user-error "Can't scatter tasks in \"%s\" agenda view" org-agenda-type) - (let ((days (read-number - (format "Scatter tasks across how many %sdays: " - (if arg "week" "")) 7))) - (setq cmd - `(let ((distance (1+ (random ,days)))) - (if arg - (let ((dist distance) - (day-of-week - (calendar-day-of-week - (calendar-gregorian-from-absolute (org-today))))) - (dotimes (i (1+ dist)) - (while (member day-of-week org-agenda-weekend-days) - (cl-incf distance) - (cl-incf day-of-week) - (when (= day-of-week 7) - (setq day-of-week 0))) - (cl-incf day-of-week) - (when (= day-of-week 7) - (setq day-of-week 0))))) - ;; silently fail when try to replan a sexp entry - (condition-case nil - (let* ((date (calendar-gregorian-from-absolute - (+ (org-today) distance))) - (time (encode-time 0 0 0 (nth 1 date) (nth 0 date) - (nth 2 date)))) - (org-agenda-schedule nil time)) - (error nil))))))) + (?S + (unless (org-agenda-check-type nil 'agenda 'timeline 'todo) + (user-error "Can't scatter tasks in \"%s\" agenda view" org-agenda-type)) + (let ((days (read-number + (format "Scatter tasks across how many %sdays: " + (if arg "week" "")) + 7))) + (setq cmd + `(lambda () + (let ((distance (1+ (random ,days)))) + (when arg + (let ((dist distance) + (day-of-week + (calendar-day-of-week + (calendar-gregorian-from-absolute (org-today))))) + (dotimes (i (1+ dist)) + (while (member day-of-week org-agenda-weekend-days) + (cl-incf distance) + (cl-incf day-of-week) + (when (= day-of-week 7) + (setq day-of-week 0))) + (cl-incf day-of-week) + (when (= day-of-week 7) + (setq day-of-week 0))))) + ;; Silently fail when try to replan a sexp entry. + (ignore-errors + (let* ((date (calendar-gregorian-from-absolute + (+ (org-today) distance))) + (time (encode-time 0 0 0 (nth 1 date) (nth 0 date) + (nth 2 date)))) + (org-agenda-schedule nil time)))))))) - ((assoc action org-agenda-bulk-custom-functions) - (setq cmd (list (cadr (assoc action org-agenda-bulk-custom-functions))) - redo-at-end t)) + (?f + (setq cmd + (intern + (completing-read "Function: " obarray #'fboundp t nil nil)))) - ((equal action ?f) - (setq cmd (list (intern - (completing-read "Function: " - obarray 'fboundp t nil nil))))) + (action + (pcase (assoc action org-agenda-bulk-custom-functions) + (`(,_ ,f) (setq cmd f) (setq redo-at-end t)) + (_ (user-error "Invalid bulk action: %c" action))))) - (t (user-error "Invalid bulk action"))) + ;; Sort the markers, to make sure that parents are handled + ;; before children. + (setq entries (sort entries + (lambda (a b) + (cond + ((eq (marker-buffer a) (marker-buffer b)) + (< (marker-position a) (marker-position b))) + (t + (string< (buffer-name (marker-buffer a)) + (buffer-name (marker-buffer b)))))))) - ;; Sort the markers, to make sure that parents are handled before children - (setq entries (sort entries - (lambda (a b) - (cond - ((equal (marker-buffer a) (marker-buffer b)) - (< (marker-position a) (marker-position b))) - (t - (string< (buffer-name (marker-buffer a)) - (buffer-name (marker-buffer b)))))))) - - ;; Now loop over all markers and apply cmd - (while (setq e (pop entries)) - (setq pos (text-property-any (point-min) (point-max) 'org-hd-marker e)) - (if (not pos) - (progn (message "Skipping removed entry at %s" e) - (setq cntskip (1+ cntskip))) - (goto-char pos) - (let (org-loop-over-headlines-in-active-region) - (eval cmd)) - ;; `post-command-hook' is not run yet. We make sure any - ;; pending log note is processed. - (when (or (memq 'org-add-log-note (default-value 'post-command-hook)) - (memq 'org-add-log-note post-command-hook)) - (org-add-log-note)) - (setq cnt (1+ cnt)))) + ;; Now loop over all markers and apply CMD. + (let ((processed 0) + (skipped 0)) + (dolist (e entries) + (let ((pos (text-property-any (point-min) (point-max) 'org-hd-marker e))) + (if (not pos) + (progn (message "Skipping removed entry at %s" e) + (cl-incf skipped)) + (goto-char pos) + (let (org-loop-over-headlines-in-active-region) (funcall cmd)) + ;; `post-command-hook' is not run yet. We make sure any + ;; pending log note is processed. + (when (or (memq 'org-add-log-note (default-value 'post-command-hook)) + (memq 'org-add-log-note post-command-hook)) + (org-add-log-note)) + (cl-incf processed)))) (when redo-at-end (org-agenda-redo)) - (unless org-agenda-persistent-marks - (org-agenda-bulk-unmark-all)) + (unless org-agenda-persistent-marks (org-agenda-bulk-unmark-all)) (message "Acted on %d entries%s%s" - cnt - (if (= cntskip 0) + processed + (if (= skipped 0) "" (format ", skipped %d (disappeared before their turn)" - cntskip)) - (if (not org-agenda-persistent-marks) - "" " (kept marked)")))))) + skipped)) + (if (not org-agenda-persistent-marks) "" " (kept marked)")))))) (defun org-agenda-capture (&optional with-time) "Call `org-capture' with the date at point.