[O] [CODE] org-open-link-from-string in a program

[Eric Abrahamsen]

Eric Abrahamsen <address@hidden> writes:

> I'm trying to write a small function that programmatically follows a
> link to a gnus message, then calls
> `gnus-summary-wide-reply-with-original' to start a reply to that
> message.

Okay, this seems like a fair amount of code for something that doesn't
actually do all that much, but here it is. I have one capture template
that incorporates a link to a gnus message in the headline (for REPLY
todos), and a different one that prompts for one or more mailto: or
bbdb: links, and puts them in the headline (with an EMAIL todo).
Sometimes I have mailto links and message links in the same header, so I
can reply to a message and copy other people on the reply.

The two main functions here (org-mail-handle-mail and
org-mail-handle-mail-agenda) look at the headline under point and
hopefully DTRT with the links they find there.

Like I said, the whole point of this is single-key-in, single-key-out
capturing and handling of email todos.

Things that are weird:

1. I've used an "org-mail" prefix, which doesn't otherwise exist.
2. It assumes you're using gnus
3. It assumes you want to reply to messages using 
`gnus-wide-reply-with-original'
4. It still seems a wee bit fragile. Gnus doesn't take kindly to be
operated non-interactively; I've used call-interactively where I can,
just in case, but sometimes odd things happen.

Anyway, there it is. I'd be happy to stick it on worg, put it in
contrib, or just leave it here. If anyone wants it tweaked or expanded
or generalized (it doesn't do org-contact contacts, for example), just
let me know.


(defvar org-mail-window-conf nil
  "Save org-buffer window configuration here, for later
  restoration.")

(defun org-mail-restore-after-send ()
  (gnus-summary-exit nil t)
  (when (window-configuration-p org-mail-window-conf)
    (set-window-configuration org-mail-window-conf))
  (call-interactively 'org-agenda-todo)) 

(defun org-mail-handle-mail (&optional interactive-p)
  "Handle mail-related links for current headline."
tC  (interactive "p")
  (unless (org-back-to-heading t)
    (error "Not in an org item"))
  (when interactive-p
    (setq org-mail-window-conf (current-window-configuration)))
  (let ((todo-kwd
         (org-element-property :todo-keyword (org-element-at-point))) 
        message mailto)
    (while (re-search-forward org-any-link-re (line-end-position) t) 
      (let ((addr (or (match-string-no-properties 2)
                      (match-string-no-properties 0))))
        (cond
         ((string-match "^<?gnus:" addr)
          (push (substring addr (match-end 0)) message))
         ((string-match "^<?mailto:"; addr)
          (push (substring addr (match-end 0)) mailto))
         ((and (featurep 'bbdb)
               (string-match-p "^<?bbdb:" addr))
          (with-current-buffer bbdb-buffer-name
            (let ((recs bbdb-records))
              (org-open-link-from-string addr)
              (let ((mail (bbdb-mail-address (bbdb-current-record))))
                (bbdb-display-records recs)
                (push mail mailto))))))))
    (cond
     (message
      (org-gnus-open (org-link-unescape (car message)))
      (call-interactively
       'gnus-summary-wide-reply-with-original)
      (when mailto
        (message-goto-to)
        (insert ", ")
        (insert (mapconcat 'identity mailto ", "))
        (message-goto-body))
      (add-to-list 'message-exit-actions
                   'org-mail-restore-after-send t))
     (mailto
      (compose-mail (mapconcat 'identity mailto ", ")
                    nil nil nil nil nil nil 
                    'org-mail-restore-after-send))
     (t
      (error "No mail-related links in headline")))))

(defun org-mail-handle-mail-agenda ()
  "Examine item at point for mail-related links, and handle them."
  (interactive)
  (org-agenda-check-type t 'agenda 'timeline 'todo 'tags)
  (org-agenda-check-no-diary)
  (let* ((marker (or (org-get-at-bol 'org-hd-marker)
                     (org-agenda-error)))
         (buffer (marker-buffer marker))
         (pos (marker-position marker)))
    (setq org-mail-window-conf (current-window-configuration))
    (with-current-buffer buffer
      (widen)
      (goto-char pos)
      (org-mail-handle-mail))))