Counsel fix org-mode tags in Emacs
Hello, another Emacs post, been using this code for probably a year so I'm sharing it.
(defun org-capture-fill-template (&optional template initial annotation) "Fill a template and return the filled template as a string. The template may still contain \"%?\" for cursor positioning." (let* ((template (or template (org-capture-get :template))) (buffer (org-capture-get :buffer)) (file (buffer-file-name (or (buffer-base-buffer buffer) buffer))) (time (let* ((c (or (org-capture-get :default-time) (current-time))) (d (decode-time c))) (if (< (nth 2 d) org-extend-today-until) (encode-time 0 59 23 (1- (nth 3 d)) (nth 4 d) (nth 5 d)) c))) (v-t (format-time-string (org-time-stamp-format nil) time)) (v-T (format-time-string (org-time-stamp-format t) time)) (v-u (format-time-string (org-time-stamp-format nil t) time)) (v-U (format-time-string (org-time-stamp-format t t) time)) (v-c (and kill-ring (current-kill 0))) (v-x (or (org-get-x-clipboard 'PRIMARY) (org-get-x-clipboard 'CLIPBOARD) (org-get-x-clipboard 'SECONDARY) "")) ;ensure it is a string ;; `initial' and `annotation' might have been passed. But if ;; the property list has them, we prefer those values. (v-i (or (plist-get org-store-link-plist :initial) (and (stringp initial) (org-no-properties initial)) (org-capture-get :initial) "")) (v-a (let ((a (or (plist-get org-store-link-plist :annotation) annotation (org-capture-get :annotation) ""))) ;; Is the link empty? Then we do not want it... (if (equal a "[[]]") "" a))) (l-re "\\[\\[\\(.*?\\)\\]\\(\\[.*?\\]\\)?\\]") (v-A (if (and v-a (string-match l-re v-a)) (replace-match "[[\\1][%^{Link description}]]" nil nil v-a) v-a)) (v-l (if (and v-a (string-match l-re v-a)) (replace-match "\\1" nil nil v-a) v-a)) (v-n user-full-name) (v-k (if (marker-buffer org-clock-marker) (org-no-properties org-clock-heading) "")) (v-K (if (marker-buffer org-clock-marker) (org-make-link-string (format "%s::*%s" (buffer-file-name (marker-buffer org-clock-marker)) v-k) v-k) "")) (v-f (or (org-capture-get :original-file-nondirectory) "")) (v-F (or (org-capture-get :original-file) "")) (org-capture--clipboards (delq nil (list v-i (org-get-x-clipboard 'PRIMARY) (org-get-x-clipboard 'CLIPBOARD) (org-get-x-clipboard 'SECONDARY) v-c)))) (setq org-store-link-plist (plist-put org-store-link-plist :annotation v-a)) (setq org-store-link-plist (plist-put org-store-link-plist :initial v-i)) (unless template (setq template "") (message "no template") (ding) (sit-for 1)) (save-window-excursion (org-switch-to-buffer-other-window (get-buffer-create "*Capture*")) (erase-buffer) (setq buffer-file-name nil) (setq mark-active nil) (insert template) (goto-char (point-min)) ;; %[] insert contents of a file. (save-excursion (while (re-search-forward "%\\[\\(.+\\)\\]" nil t) (let ((filename (expand-file-name (match-string 1))) (beg (copy-marker (match-beginning 0))) (end (copy-marker (match-end 0)))) (unless (org-capture-escaped-%) (delete-region beg end) (set-marker beg nil) (set-marker end nil) (condition-case error (insert-file-contents filename) (error (insert (format "%%![couldn not insert %s: %s]" filename error)))))))) ;; Mark %() embedded elisp for later evaluation. (org-capture-expand-embedded-elisp 'mark) ;; Expand non-interactive templates. (let ((regexp "%\\(:[-a-za-z]+\\|<\\([^>\n]+\\)>\\|[aAcfFikKlntTuUx]\\)")) (save-excursion (while (re-search-forward regexp nil t) ;; `org-capture-escaped-%' may modify buffer and cripple ;; match-data. Use markers instead. Ditto for other ;; templates. (let ((pos (copy-marker (match-beginning 0))) (end (copy-marker (match-end 0))) (value (match-string 1)) (time-string (match-string 2))) (unless (org-capture-escaped-%) (delete-region pos end) (set-marker pos nil) (set-marker end nil) (let* ((inside-sexp? (org-capture-inside-embedded-elisp-p)) (replacement (pcase (string-to-char value) (?< (format-time-string time-string time)) (?: (or (plist-get org-store-link-plist (intern value)) "")) (?i (if inside-sexp? v-i ;; Outside embedded Lisp, repeat leading ;; characters before initial place holder ;; every line. (let ((lead (buffer-substring-no-properties (line-beginning-position) (point)))) (replace-regexp-in-string "\n\\(.\\)" (concat lead "\\1") v-i nil nil 1)))) (?a v-a) (?A v-A) (?c v-c) (?f v-f) (?F v-F) (?k v-k) (?K v-K) (?l v-l) (?n v-n) (?t v-t) (?T v-T) (?u v-u) (?U v-U) (?x v-x)))) (insert (if inside-sexp? ;; Escape sensitive characters. (replace-regexp-in-string "[\\\"]" "\\\\\\&" replacement) replacement)))))))) ;; Expand %() embedded Elisp. Limit to Sexp originally marked. (org-capture-expand-embedded-elisp) ;; Expand interactive templates. This is the last step so that ;; template is mostly expanded when prompting happens. Turn on ;; Org mode and set local variables. This is to support ;; completion in interactive prompts. (let ((org-inhibit-startup t)) (org-mode)) (org-clone-local-variables buffer "\\`org-") (let (strings) ; Stores interactive answers. (save-excursion (let ((regexp "%\\^\\(?:{\\([^}]*\\)}\\)?\\([CgGLptTuU]\\)?")) (while (re-search-forward regexp nil t) (let* ((items (and (match-end 1) (save-match-data (split-string (match-string-no-properties 1) "|")))) (key (match-string 2)) (beg (copy-marker (match-beginning 0))) (end (copy-marker (match-end 0))) (prompt (nth 0 items)) (default (nth 1 items)) (completions (nthcdr 2 items))) (unless (org-capture-escaped-%) (delete-region beg end) (set-marker beg nil) (set-marker end nil) (pcase key ((or "G" "g") (my/set-tags)) ((or "C" "L") (let ((insert-fun (if (equal key "C") #'insert (lambda (s) (org-insert-link 0 s))))) (pcase org-capture--clipboards (`nil nil) (`(,value) (funcall insert-fun value)) (`(,first-value . ,_) (funcall insert-fun (read-string "Clipboard/kill value: " first-value 'org-capture--clipboards first-value))) (_ (error "Invalid `org-capture--clipboards' value: %S" org-capture--clipboards))))) ("p" (org-set-property prompt nil)) ((or "t" "T" "u" "U") ;; These are the date/time related ones. (let* ((upcase? (equal (upcase key) key)) (org-end-time-was-given nil) (time (org-read-date upcase? t nil prompt))) (org-insert-time-stamp time (or org-time-was-given upcase?) (member key '("u" "U")) nil nil (list org-end-time-was-given)))) (`nil ;; Load history list for current prompt. (setq org-capture--prompt-history (gethash prompt org-capture--prompt-history-table)) (push (org-completing-read (concat (or prompt "Enter string") (and default (format " [%s]" default)) ": ") completions nil nil nil 'org-capture--prompt-history default) strings) (insert (car strings)) ;; Save updated history list for current prompt. (puthash prompt org-capture--prompt-history org-capture--prompt-history-table)) (_ (error "Unknown template placeholder: \"%%^%s\"" key)))))))) ;; Replace %n escapes with nth %^{...} string. (setq strings (nreverse strings)) (save-excursion (while (re-search-forward "%\\\\\\([1-9][0-9]*\\)" nil t) (unless (org-capture-escaped-%) (replace-match (nth (1- (string-to-number (match-string 1))) strings) nil t))))) ;; Make sure there are no empty lines before the text, and that ;; it ends with a newline character. (skip-chars-forward " \t\n") (delete-region (point-min) (line-beginning-position)) (goto-char (point-max)) (skip-chars-backward " \t\n") (delete-region (point) (point-max)) (insert "\n") ;; Return the expanded template and kill the capture buffer. (untabify (point-min) (point-max)) (set-buffer-modified-p nil) (prog1 (buffer-substring-no-properties (point-min) (point-max)) (kill-buffer (current-buffer)))))) ;; complete from all agenda files as default behavior due to bug to the procedure (defun counsel-org-tag () "Add or remove tags in `org-mode'." (interactive) (save-excursion (if (eq major-mode 'org-agenda-mode) (if org-agenda-bulk-marked-entries (setq counsel-org-tags nil) (let ((hdmarker (or (org-get-at-bol 'org-hd-marker) (org-agenda-error)))) (with-current-buffer (marker-buffer hdmarker) (goto-char hdmarker) (setq counsel-org-tags (split-string (org-get-tags-string) ":" t))))) (unless (org-at-heading-p) (org-back-to-heading t)) (setq counsel-org-tags (split-string (org-get-tags-string) ":" t))) (let ((org-setting-tags t) (org-last-tags-completion-table (append org-tag-persistent-alist (org-global-tags-completion-table (org-agenda-files))))) (ivy-read (counsel-org-tag-prompt) (lambda (str &rest _unused) (delete-dups (all-completions str 'org-tags-completion-function))) :history 'org-tags-history :action 'counsel-org-tag-action :caller 'counsel-org-tag)))) (defun my/set-tags (&optional v1 v2) (interactive "P") (counsel-org-tag)) (fset 'org-set-tags-command 'my/set-tags) (provide 'org-fix-capture-counsel)
