1 ;;; gnorb-org.el --- The Org-centric functions of gnorb
3 ;; Copyright (C) 2014 Free Software Foundation, Inc.
5 ;; Author: Eric Abrahamsen <eric@ericabrahamsen.net>
8 ;; This program is free software; you can redistribute it and/or modify
9 ;; it under the terms of the GNU General Public License as published by
10 ;; the Free Software Foundation, either version 3 of the License, or
11 ;; (at your option) any later version.
13 ;; This program is distributed in the hope that it will be useful,
14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ;; GNU General Public License for more details.
18 ;; You should have received a copy of the GNU General Public License
19 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
27 (require 'gnorb-utils)
30 (defgroup gnorb-org nil
31 "The Org bits of Gnorb."
35 (defcustom gnorb-org-after-message-setup-hook nil
36 "Hook run in a message buffer after setting up the message from
37 `gnorb-org-handle-mail' or `gnorb-org-email-subtree'."
41 (defcustom gnorb-org-trigger-actions
42 '(("todo state" . todo)
44 ("don't associate" . no-associate)
45 ("only associate" . associate)
46 ("capture to child" . cap-child)
47 ("capture to sibling" . cap-sib))
48 "List of potential actions that can be taken on headings.
50 When triggering an Org heading after receiving or sending a
51 message, this option lists the possible actions to take. Built-in
54 todo state: Associate the message, and change TODO state.
55 take note: Associate the message, and take a note.
56 don't associate: Do nothing at all, don't connect the message and TODO.
57 only associate: Associate the message with this heading, do nothing else.
58 capture to child: Associate this message with a new child heading.
59 capture to sibling: Associate this message with a new sibling heading.
61 You can reorder this list or remove items as suits your workflow.
62 The two \"capture\" options will use the value of
63 `gnorb-gnus-new-todo-capture-key' to find the appropriate
66 You can also add custom actions to the list. Actions should be a
67 cons of a string tag and a symbol indicating a custom function.
68 This function will be called on the heading in question, and
69 passed a plist containing information about the message from
70 which we're triggering."
74 (defcustom gnorb-org-msg-id-key "GNORB_MSG_ID"
75 "The name of the org property used to store the Message-IDs
76 from relevant messages. This is no longer used, and will be
81 (defcustom gnorb-org-mail-scan-scope 2
82 "Number of paragraphs to scan for mail-related links.
84 When handling a TODO heading with `gnorb-org-handle-mail', Gnorb
85 will typically reply to the most recent message associated with
86 this heading. If there are no such messages, or message tracking
87 is disabled entirely, or `gnorb-org-handle-mail' has been called
88 with a prefix arg, the heading and body text of the subtree under
89 point will instead be scanned for gnus:, mailto:, and bbdb:
90 links. This option controls how many paragraphs of body text to
91 scan. Set to 0 to only look in the heading.")
93 (make-obsolete-variable
94 'gnorb-org-mail-scan-strategies
95 "This variable has been superseded by `gnorb-org-trigger-actions'"
96 "September 12, 2014" 'set)
98 (make-obsolete-variable
99 'gnorb-org-mail-scan-state-changes
100 "This variable has been superseded by `gnorb-org-trigger-actions'"
101 "September 12, 2014" 'set)
103 (make-obsolete-variable
104 'gnorb-org-mail-scan-function
105 "This variable has been superseded by `gnorb-org-trigger-actions'"
106 "September 12, 2014" 'set)
108 (defcustom gnorb-org-find-candidates-match nil
109 "When scanning all org files for heading related to an incoming
110 message, this option will limit which headings will be offered as
111 target candidates. Specifically it will be used as the second
112 argument to `org-map-entries', and syntax is the same as that
113 used in an agenda tags view."
118 (defun gnorb-org-contact-link (rec)
119 "Prompt for a BBDB record and insert a link to that record at
122 There's really no reason to use this instead of regular old
123 `org-insert-link' with BBDB completion. But there might be in the
125 ;; this needs to handle an active region.
126 (interactive (list (gnorb-prompt-for-bbdb-record)))
127 (let* ((name (bbdb-record-name rec))
128 (link (concat "bbdb:" (org-link-escape name))))
129 (org-store-link-props :type "bbdb" :name name
130 :link link :description name)
131 (if (called-interactively-p 'any)
132 (insert (format "[[%s][%s]]" link name))
135 (defun gnorb-org-restore-after-send ()
136 "After an email is sent, go through all the org ids that might
137 have been in the outgoing message's headers and call
138 `gnorb-trigger-todo-action' on each one, then put us back where
140 (delete-other-windows)
141 (dolist (id gnorb-message-org-ids)
143 (gnorb-trigger-todo-action nil id))
144 ;; this is a little unnecessary, but it may save grief
145 (setq gnorb-gnus-message-info nil)
146 (setq gnorb-message-org-ids nil)
147 (gnorb-restore-layout))
149 (defun gnorb-org-extract-links (&optional arg region)
150 "See if there are viable links in the subtree under point."
151 ;; We're not currently using the arg. What could we do with it?
153 ;; If the region was active, only use the region
155 (push (buffer-substring (car region) (cdr region))
157 ;; Otherwise collect the heading text, and all the paragraph
160 (org-narrow-to-subtree)
161 (let ((head (org-element-at-point))
162 (tree (org-element-parse-buffer)))
163 (push (org-element-property
167 (org-element-map tree '(paragraph drawer)
169 (push (org-element-interpret-data p)
173 ;; Limit number of paragraphs based on
174 ;; `gnorb-org-mail-scan-scope'
176 (cond ((eq gnorb-org-mail-scan-scope 'all)
178 ((numberp gnorb-org-mail-scan-scope)
182 (1+ gnorb-org-mail-scan-scope))))
183 ;; We could provide more options here. 'tree vs
184 ;; 'subtree, for instance.
191 (goto-char (point-min))
192 (gnorb-scan-links (point-max) 'gnus 'mail 'bbdb)))))
194 (defun gnorb-org-extract-mail-stuff (&optional arg region)
195 "Decide how to hande the Org heading under point as an email task.
197 See the docstring of `gnorb-org-handle-mail' for details."
198 (if (or (not gnorb-tracking-enabled)
200 (gnorb-org-extract-links arg region)
201 ;; Get all the messages associated with the IDS in this subtree.
206 (gnorb-registry-org-id-search id))
207 (gnorb-collect-ids)))))
208 (gnorb-org-extract-mail-tracking assoc-msg-ids arg region))))
210 (defun gnorb-org-extract-mail-tracking (assoc-msg-ids &optional arg region)
212 (let* ((all-links (gnorb-org-extract-links nil region))
213 ;; The latest (by the creation-time registry key) of all the
214 ;; tracked messages that were not sent by our user.
221 (let ((from (car (gnus-registry-get-id-key m 'sender))))
224 user-mail-address from)
226 message-alternative-emails from))))
230 (car (gnus-registry-get-id-key l 'creation-time))
231 (car (gnus-registry-get-id-key r 'creation-time))))))))
234 (gnorb-msg-id-to-link latest-msg-id))))
236 ;; If there are no tracked messages, or the user has specifically
237 ;; requested we ignore them with the prefix arg, just return the
238 ;; found links in the subtree.
242 ;; Otherwise ignore the other links in the subtree, and return
243 ;; the latest message.
245 `(:gnus ,(list msg-id-link))))))
247 (defvar message-beginning-of-line)
249 (defun gnorb-org-setup-message
250 (&optional messages mails from cc bcc attachments text ids)
251 "Common message setup routine for other gnorb-org commands.
252 MESSAGES is a list of gnus links pointing to messages -- we
253 currently only use the first of the list. MAILS is a list of
254 email address strings suitable for inserting in the To header.
255 ATTACHMENTS is a list of filenames to attach. TEXT is a string or
256 buffer, which is inserted in the message body. IDS is one or more
257 Org heading ids, associating the outgoing message with those
259 (require 'gnorb-gnus)
261 ;; Either compose new message...
263 ;; ...or follow link and start reply.
265 (gnorb-reply-to-gnus-link (car messages))
266 (error (gnorb-restore-layout)
267 (signal (car err) (cdr err)))))
268 ;; Add MAILS to message To header.
273 (insert (mapconcat 'identity mails ", ")))
274 ;; Commenting this out because
275 ;; `gnorb-gnus-check-outgoing-headers' is set unconditionally in the
276 ;; `message-send-hook, so this should be redundant. Also, we've
277 ;; switched to using message-send-actions.
280 ;; 'message-exit-actions 'gnorb-org-restore-after-send t) Set
281 ;; headers from MAIL_* properties (from, cc, and bcc).
284 (funcall (intern (format "message-goto-%s" (car h))))
285 (let ((message-beginning-of-line t)
286 (show-trailing-whitespace t))
287 (message-beginning-of-line)
291 (dolist (h `((from . ,from) (cc . ,cc) (bcc . ,bcc)))
293 ;; attach ATTACHMENTS
295 (lambda (a) (format "Attach %s to outgoing message? "
296 (file-name-nondirectory a)))
298 (mml-attach-file a (mm-default-file-encoding a)
301 '("file" "files" "attach"))
302 ;; insert text, if any
307 (insert-buffer-substring text)
309 ;; insert org ids, if any
312 (setq ids (list ids)))
315 (message-narrow-to-headers)
317 (goto-char (point-at-bol))
319 ;; this function hardly does anything
320 (message-insert-header
321 (intern gnorb-mail-header) i)))))
322 ;; put point somewhere reasonable
323 (if (or mails messages)
325 (message-goto-subject)
328 (run-hooks 'gnorb-org-after-message-setup-hook))
330 (defun gnorb-org-attachment-list (&optional id)
331 "Get a list of files (absolute filenames) attached to the
332 current heading, or the heading indicated by optional argument ID."
333 (when (featurep 'org-attach)
334 (let* ((attach-dir (save-excursion
341 (expand-file-name f attach-dir))
342 (org-attach-file-list attach-dir))))
345 (defvar message-mode-hook)
348 (defun gnorb-org-handle-mail (&optional arg text file)
349 "Handle current headline as a mail TODO.
351 How this function behaves depends on whether you're using Gnorb
352 for email tracking, also on the prefix arg, and on the active
355 If tracking is enabled and there is no prefix arg, Gnorb will
356 begin a reply to the newest associated message that wasn't sent
357 by the user -- ie, the Sender header doesn't match
358 `user-mail-address' or `message-alternative-emails'.
360 If tracking is enabled and there is a prefix arg, ignore the
361 tracked messages and instead scan the subtree for mail-related
362 links. This means links prefixed with gnus:, mailto:, or bbdb:.
363 See `gnorb-org-mail-scan-scope' to limit the scope of this scan.
364 Do something appropriate with the resulting links.
366 With a double prefix arg, ignore all tracked messages and all
367 links, and compose a blank new message.
369 If tracking is enabled and you want to reply to a
370 specific (earlier) message in the tracking history, use
371 `gnorb-org-view' to open an nnir *Summary* buffer containing all
372 the messages, and reply to the one you want. Your reply will be
373 automatically tracked, as well.
375 If tracking is not enabled and you want to use a specific link in
376 the subtree as a basis for the email action, then put the region
377 around that link before you call this message."
379 (setq gnorb-window-conf (current-window-configuration))
380 (move-marker gnorb-return-marker (point))
381 (when (eq major-mode 'org-agenda-mode)
382 ;; If this is all the different types, we could skip the check.
383 (org-agenda-check-type t 'agenda 'timeline 'todo 'tags 'search)
384 (org-agenda-check-no-diary)
385 (let* ((marker (or (org-get-at-bol 'org-hd-marker)
387 (buffer (marker-buffer marker))
388 (pos (marker-position marker)))
389 (switch-to-buffer buffer)
394 (cons (region-beginning) (region-end)))))
397 (unless (org-back-to-heading t)
398 (error "Not in an org item"))
399 (cl-flet ((mp (p) (org-entry-get (point) p t)))
400 ;; Double prefix means ignore everything and compose a blank
402 (let* ((links (unless (equal arg '(16))
403 (gnorb-org-extract-mail-stuff arg region)))
404 (attachments (gnorb-org-attachment-list))
405 (from (mp "MAIL_FROM"))
407 (bcc (mp "MAIL_BCC"))
408 (org-id (org-id-get-create))
409 (recs (plist-get links :bbdb))
410 (message-mode-hook (copy-sequence message-mode-hook))
413 (cons file attachments))
419 (car (bbdb-message-search
420 (org-link-unescape r)
425 (push (bbdb-mail-address r) mails)))
427 gnorb-bbdb-posting-styles)
428 (add-hook 'message-mode-hook
430 (gnorb-bbdb-configure-posting-styles (cdr recs))
431 (gnorb-bbdb-configure-posting-styles (list (car recs))))))
432 (gnorb-org-setup-message
433 (plist-get links :gnus)
434 (append mails (plist-get links :mail))
436 attachments text org-id))))))
440 (defcustom gnorb-org-email-subtree-text-parameters nil
441 "A plist of export parameters corresponding to the EXT-PLIST
442 argument to the export functions, for use when exporting to
447 (defcustom gnorb-org-email-subtree-file-parameters nil
448 "A plist of export parameters corresponding to the EXT-PLIST
449 argument to the export functions, for use when exporting to a
454 (defcustom gnorb-org-email-subtree-text-options '(nil t nil t)
455 "A list of ts and nils corresponding to Org's export options,
456 to be used when exporting to text. The options, in order, are
457 async, subtreep, visible-only, and body-only."
461 (defcustom gnorb-org-email-subtree-file-options '(nil t nil nil)
462 "A list of ts and nils corresponding to Org's export options,
463 to be used when exporting to a file. The options, in order, are
464 async, subtreep, visible-only, and body-only."
468 (defcustom gnorb-org-export-extensions
476 (odt ".odt") ; not really, though
479 "Correspondence between export backends and their
480 respective (usual) file extensions. Ugly way to do it, but what
484 (defvar org-export-show-temporary-export-buffer)
487 (defun gnorb-org-email-subtree (&optional arg)
488 "Call on a subtree to export it either to a text string or a file,
489 then compose a mail message either with the exported text
490 inserted into the message body, or the exported file attached to
493 Export options default to the following: When exporting to a
494 buffer: async = nil, subtreep = t, visible-only = nil, body-only
495 = t. Options are the same for files, except body-only is set to
496 nil. Customize `gnorb-org-email-subtree-text-options' and
497 `gnorb-org-email-subtree-file-options', respectively.
499 Customize `gnorb-org-email-subtree-parameters' to your preferred
500 default set of parameters."
501 ;; I sure would have liked to use the built-in dispatch ui, but it's
502 ;; got too much hard-coded stuff.
504 (org-back-to-heading t)
505 (let* ((backend-string
509 (symbol-name (org-export-backend-name b)))
510 org-export--registered-backends)
512 (backend-symbol (intern backend-string))
513 (f-or-t (org-completing-read "Export as file or text? "
514 '("file" "text") nil t))
515 (org-export-show-temporary-export-buffer nil)
516 (opts (if (equal f-or-t "text")
517 gnorb-org-email-subtree-text-options
518 gnorb-org-email-subtree-file-options))
520 (if (equal f-or-t "text")
521 (apply 'org-export-to-buffer
525 ,gnorb-org-email-subtree-text-parameters))
526 (apply 'org-export-to-file
528 ,(org-export-output-file-name
529 (cl-second (assoc backend-symbol gnorb-org-export-extensions))
532 ,gnorb-org-email-subtree-file-parameters))))
534 (setq gnorb-window-conf (current-window-configuration))
535 (move-marker gnorb-return-marker (point))
539 (gnorb-org-handle-mail arg text file)))
541 (defcustom gnorb-org-capture-collect-link-p t
542 "Should the capture process store a link to the gnus message or
543 BBDB record under point, even if it's not part of the template?
544 You'll probably end up needing it, anyway."
547 (defun gnorb-org-capture-collect-link ()
548 (when gnorb-org-capture-collect-link-p
549 (let ((buf (org-capture-get :original-buffer)))
551 (with-current-buffer buf
552 (when (memq major-mode '(gnus-summary-mode
555 (call-interactively 'org-store-link)))))))
557 (add-hook 'org-capture-mode-hook 'gnorb-org-capture-collect-link)
559 ;;; Agenda/BBDB popup stuff
561 (defcustom gnorb-org-agenda-popup-bbdb nil
562 "Should Agenda tags search pop up a BBDB buffer with matching
565 Records are considered matching if they have an `org-tags' field
566 matching the current Agenda search. The name of that field can be
567 customized with `gnorb-bbdb-org-tag-field'."
570 (defcustom gnorb-org-bbdb-popup-layout 'pop-up-multi-line
571 "Default BBDB buffer layout for automatic Org Agenda display."
573 :type '(choice (const one-line)
575 (const full-multi-line)
579 (defun gnorb-org-popup-bbdb (&optional str)
580 "In an `org-tags-view' Agenda buffer, pop up a BBDB buffer
581 showing records whose `org-tags' field matches the current tags
583 ;; I was hoping to use `org-make-tags-matcher' directly, then snag
584 ;; the tagmatcher from the resulting value, but there doesn't seem
585 ;; to be a reliable way of only getting the tag-related returns. But
586 ;; I'd still like to use that function. So an ugly hack to first
587 ;; remove non-tag contents from the query string, and then make a
588 ;; new call to `org-make-tags-matcher'.
590 (require 'gnorb-bbdb)
593 (and (eq major-mode 'org-agenda-mode)
594 (eq org-agenda-type 'tags))
595 (or (called-interactively-p 'any)
596 gnorb-org-agenda-popup-bbdb))
597 (let ((todo-only nil)
598 (str (or str org-agenda-query-string))
599 (re "^&?\\([-+:]\\)?\\({[^}]+}\\|LEVEL\\([<=>]\\{1,2\\}\\)\\([0-9]+\\)\\|\\(\\(?:[[:alnum:]_]+\\(?:\\\\-\\)*\\)+\\)\\([<>=]\\{1,2\\}\\)\\({[^}]+}\\|\"[^\"]*\"\\|-?[.0-9]+\\(?:[eE][-+]?[0-9]+\\)?\\)\\|[[:alnum:]_@#%]+\\)")
600 or-terms term rest out-or acc tag-clause)
601 (setq or-terms (org-split-string str "|"))
602 (while (setq term (pop or-terms))
604 (while (string-match re term)
605 (setq rest (substring term (match-end 0)))
606 (let ((sub-term (match-string 0 term)))
607 (unless (save-match-data ; this isn't a tag, don't want it
608 (string-match "\\([<>=]\\)" sub-term))
611 (push (mapconcat 'identity (nreverse acc) "") out-or))
612 (setq str (mapconcat 'identity (nreverse out-or) "|"))
613 (setq tag-clause (cdr (org-make-tags-matcher str)))
614 (unless (equal str "")
618 (let ((rec-tags (bbdb-record-xfield
619 r gnorb-bbdb-org-tag-field)))
621 (let ((tags-list (if (stringp rec-tags)
622 (org-split-string rec-tags ":")
625 (org-trust-scanner-tags t))
626 (eval tag-clause)))))
628 ((eq major-mode 'org-mode)
630 (org-back-to-heading)
631 (let ((bound (org-element-property
632 :end (org-element-at-point)))
634 (while (re-search-forward
635 org-bracket-link-analytic-regexp bound t)
636 (when (string-match-p "bbdb" (match-string 2))
637 (setq desc (match-string 5)
638 rec (bbdb-search (bbdb-records) desc desc desc)
639 recs (append recs rec))))))))
641 (bbdb-display-records
642 recs gnorb-org-bbdb-popup-layout)
643 (when (get-buffer-window bbdb-buffer-name)
645 (get-buffer-window bbdb-buffer-name)))
646 (when (called-interactively-p 'any)
647 (message "No relevant BBDB records")))))
649 (if (featurep 'gnorb-bbdb)
650 (add-hook 'org-agenda-finalize-hook 'gnorb-org-popup-bbdb))
652 ;;; Groups from the gnorb gnus server backend
655 (defun gnorb-org-view (arg)
656 "Search the subtree at point for links to gnus messages, and
657 then show them in an ephemeral group, in Gnus.
659 With a prefix arg, create a search group that will persist across
660 Gnus sessions, and can be refreshed.
662 This won't work unless you've added a \"nngnorb\" server to
663 your gnus select methods."
664 ;; this should also work on the active region, if there is one.
666 (require 'gnorb-gnus)
667 (setq gnorb-window-conf (current-window-configuration))
668 (move-marker gnorb-return-marker (point))
669 (when (eq major-mode 'org-agenda-mode)
670 (org-agenda-check-type t 'agenda 'timeline 'todo 'tags)
671 (org-agenda-check-no-diary)
672 (let* ((marker (or (org-get-at-bol 'org-hd-marker)
674 (buffer (marker-buffer marker))
675 (pos (marker-position marker)))
676 (switch-to-buffer buffer)
681 (org-back-to-heading)
682 (setq id (concat "id+" (org-id-get-create)))
683 (gnorb-gnus-search-messages
685 (replace-regexp-in-string
686 org-bracket-link-regexp "\\3"
687 (nth 4 (org-heading-components)))
688 `(when (and (window-configuration-p gnorb-window-conf)
690 (set-window-configuration gnorb-window-conf)
691 (goto-char gnorb-return-marker))))))
694 ;;; gnorb-org.el ends here