forked from mirrors/org-mode
org-agenda: Small refactoring
* lisp/org-agenda.el (org-agenda-bulk-action): Small refactoring. Two `eval' less in the code base.
This commit is contained in:
Nicolas Goaziou
parent
a842ae1d38
commit
4f578a3f7f
|
|
@ -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.
|
||||
|
|
|
|||
Loading…
Reference in New Issue