code.delx.au - gnu-emacs-elpa/blob - packages/gnorb/gnorb-utils.el

   1 ;;; gnorb-utils.el --- Common utilities for all gnorb stuff.
   2
   3 ;; Copyright (C) 2014  Eric Abrahamsen
   4
   5 ;; Author: Eric Abrahamsen <eric@ericabrahamsen.net>
   6 ;; Keywords:
   7
   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.
  12
  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.
  17
  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/>.
  20
  21 ;;; Commentary:
  22
  23 ;;
  24
  25 ;;; Code:
  26
  27 (require 'cl)
  28 (require 'mailcap)
  29 (require 'gnus)
  30 ;(require 'message)
  31 (require 'bbdb)
  32 (require 'org)
  33 (require 'org-bbdb)
  34 (require 'org-gnus)
  35
  36 (mailcap-parse-mimetypes)
  37
  38 (defgroup gnorb nil
  39   "Glue code between Gnus, Org, and BBDB."
  40   :tag "Gnorb")
  41
  42 (make-obsolete-variable
  43  'gnorb-trigger-todo-default
  44  "This variable has been superseded by
  45 `gnorb-org-trigger-actions'"
  46  "September 8, 2014" 'set)
  47
  48 (defun gnorb-prompt-for-bbdb-record ()
  49   "Prompt the user for a BBDB record."
  50   (let ((recs (bbdb-records))
  51         name)
  52     (while (> (length recs) 1)
  53       (setq name
  54             (completing-read
  55              (format "Filter records by regexp (%d remaining): "
  56                      (length recs))
  57              (mapcar 'bbdb-record-name recs)))
  58       (setq recs (bbdb-search recs name name name nil nil)))
  59     (if recs
  60         (car recs)
  61       (error "No matching records"))))
  62
  63 (defvar gnorb-tmp-dir (make-temp-file "emacs-gnorb" t)
  64   "Temporary directory where attachments etc are saved.")
  65
  66 (defvar gnorb-message-org-ids nil
  67   "List of Org heading IDs from the outgoing Gnus message, used
  68   to mark mail TODOs as done once the message is sent."
  69   ;; The send hook either populates this, or sets it to nil, depending
  70   ;; on whether the message in question has an Org id header. Then
  71   ;; `gnorb-org-restore-after-send' checks for it and acts
  72   ;; appropriately, then sets it to nil.
  73   )
  74
  75 (defvar gnorb-window-conf nil
  76   "Save window configurations here, for restoration after mails
  77 are sent, or Org headings triggered.")
  78
  79 (defvar gnorb-return-marker (make-marker)
  80   "Return point here after various actions, to be used together
  81 with `gnorb-window-conf'.")
  82
  83 (defcustom gnorb-mail-header "X-Org-ID"
  84   "Name of the mail header used to store the ID of a related Org
  85   heading. Only used locally: always stripped when the mail is
  86   sent."
  87   :group 'gnorb
  88   :type 'string)
  89
  90 ;;; this is just ghastly, but the value of this var is single regexp
  91 ;;; group containing various header names, and we want our value
  92 ;;; inside that group.
  93 (eval-after-load 'message
  94   `(let ((ign-headers-list
  95           (split-string message-ignored-mail-headers
  96                         "|"))
  97          (our-val (concat gnorb-mail-header "\\")))
  98      (unless (member our-val ign-headers-list)
  99        (setq ign-headers-list
 100              `(,@(butlast ign-headers-list 1) ,our-val
 101                ,@(last ign-headers-list 1)))
 102        (setq message-ignored-mail-headers
 103              (mapconcat
 104               'identity ign-headers-list "|")))))
 105
 106 (defun gnorb-restore-layout ()
 107   "Restore window layout and value of point after a Gnorb command.
 108
 109 Some Gnorb commands change the window layout (ie `gnorb-org-view'
 110 or incoming email triggering). This command restores the layout
 111 to what it was. Bind it to a global key, or to local keys in Org
 112 and Gnus and BBDB maps."
 113   (interactive)
 114   (when (window-configuration-p gnorb-window-conf)
 115     (set-window-configuration gnorb-window-conf)
 116     (when (buffer-live-p (marker-buffer gnorb-return-marker))
 117       (goto-char gnorb-return-marker))))
 118
 119 (defun gnorb-trigger-todo-action (arg &optional id)
 120   "Do the actual restore action. Two main things here. First: if
 121 we were in the agenda when this was called, then keep us in the
 122 agenda. Then let the user choose an action from the value of
 123 `gnorb-org-trigger-actions'."
 124   (let ((agenda-p (eq major-mode 'org-agenda-mode))
 125         (action (cdr (assoc
 126                       (org-completing-read
 127                        "Action to take: "
 128                        gnorb-org-trigger-actions nil t)
 129                       gnorb-org-trigger-actions)))
 130         (root-marker (make-marker)))
 131     ;; Place the marker for the relevant TODO heading.
 132     (cond (agenda-p
 133            (setq root-marker
 134                  (copy-marker
 135                   (org-get-at-bol 'org-hd-marker))))
 136           ((derived-mode-p 'org-mode)
 137            (move-marker root-marker (point-at-bol)))
 138           (id
 139            (save-excursion
 140              (org-id-goto id)
 141              (move-marker root-marker (point-at-bol)))))
 142     ;; Query about attaching email attachments.
 143     (org-with-point-at root-marker
 144       (map-y-or-n-p
 145        (lambda (a)
 146          (format "Attach %s to heading? "
 147                  (file-name-nondirectory a)))
 148        (lambda (a) (org-attach-attach a nil 'mv))
 149        gnorb-gnus-capture-attachments
 150        '("file" "files" "attach")))
 151     (setq gnorb-gnus-capture-attachments nil)
 152     (cl-labels
 153         ((make-entry
 154           (id)
 155           (gnorb-registry-make-entry
 156            (plist-get gnorb-gnus-message-info :msg-id)
 157            (plist-get gnorb-gnus-message-info :from)
 158            (plist-get gnorb-gnus-message-info :subject)
 159            id
 160            (plist-get gnorb-gnus-message-info :group))))
 161       ;; Handle our action.
 162       (cond ((eq action 'note)
 163              (org-with-point-at root-marker
 164                (make-entry (org-id-get-create))
 165                (call-interactively 'org-add-note)))
 166             ((eq action 'todo)
 167              (if agenda-p
 168                  (progn
 169                    (org-with-point-at root-marker
 170                     (make-entry (org-id-get-create)))
 171                    (call-interactively 'org-agenda-todo))
 172                (org-with-point-at root-marker
 173                  (make-entry (org-id-get-create))
 174                  (call-interactively 'org-todo))))
 175             ((eq action 'no-associate)
 176              nil)
 177             ((eq action 'associate)
 178              (org-with-point-at root-marker
 179                (make-entry (org-id-get-create))))
 180             ((fboundp action)
 181              (org-with-point-at root-marker
 182                (make-entry (org-id-get-create))
 183                (funcall action gnorb-gnus-message-info)))))))
 184
 185 (defun gnorb-pretty-outline (id &optional kw)
 186   "Return pretty outline path of the Org heading indicated by ID.
 187
 188 If the KW argument is true, add the TODO keyword into the path."
 189   (org-with-point-at (org-id-find id t)
 190     (let ((el (org-element-at-point)))
 191       (concat
 192        (if kw
 193            (format "(%s): "
 194                    (org-element-property :todo-keyword el))
 195          "")
 196        (org-format-outline-path
 197         (append
 198          (list
 199           (file-name-nondirectory
 200            (buffer-file-name
 201             (org-base-buffer (current-buffer)))))
 202          (org-get-outline-path)
 203          (list
 204           (replace-regexp-in-string
 205            org-bracket-link-regexp
 206            "\\3" (org-element-property :raw-value el)))))))))
 207
 208 (defun gnorb-scan-links (bound &rest types)
 209   "Scan from point to BOUND looking for links of type in TYPES.
 210
 211 TYPES is a list of symbols, possible values include 'bbdb, 'mail,
 212 and 'gnus."
 213   ;; this function could be refactored somewhat -- lots of code
 214   ;; repetition. It also should be a little faster for when we're
 215   ;; scanning for gnus links only, that's a little slow. We should
 216   ;; probably use a different regexp based on the value of TYPES.
 217   ;;
 218   ;; This function should also *not* be responsible for unescaping
 219   ;; links -- we don't know what they're going to be used for, and
 220   ;; unescaped is safer.
 221   (unless (= (point) bound)
 222     (let (addr gnus mail bbdb)
 223       (while (re-search-forward org-any-link-re bound t)
 224         (setq addr (or (match-string-no-properties 2)
 225                        (match-string-no-properties 0)))
 226         (cond
 227          ((and (memq 'gnus types)
 228                (string-match "^<?gnus:" addr))
 229           (push (substring addr (match-end 0)) gnus))
 230          ((and (memq 'mail types)
 231                (string-match "^<?mailto:" addr))
 232           (push (substring addr (match-end 0)) mail))
 233          ((and (memq 'bbdb types)
 234                (string-match "^<?bbdb:" addr))
 235           (push (substring addr (match-end 0)) bbdb))))
 236       `(:gnus ,(reverse gnus) :mail ,(reverse mail) :bbdb ,(reverse bbdb)))))
 237
 238 (defun gnorb-msg-id-to-link (msg-id)
 239   "Given a message id, try to create a full org link to the
 240 message."
 241   (let ((server-group (gnorb-msg-id-to-group msg-id)))
 242     (when server-group
 243       (org-link-escape (concat server-group "#" msg-id)))))
 244
 245 (defun gnorb-msg-id-to-group (msg-id)
 246   "Given a message id, try to find the group it's in.
 247
 248 So far we're checking the registry, then the groups in
 249 `gnorb-gnus-sent-groups'. Use search engines? Other clever
 250 methods?"
 251   (let (candidates server-group)
 252     (catch 'found
 253       (when gnorb-tracking-enabled
 254         ;; Make a big list of all the groups where this message might
 255         ;; conceivably be.
 256         (setq candidates
 257               (append (gnus-registry-get-id-key msg-id 'group)
 258                       gnorb-gnus-sent-groups))
 259         (while (setq server-group (pop candidates))
 260           (when (and (stringp server-group)
 261                      (not
 262                       (string-match-p
 263                        "\\(nnir\\|nnvirtual\\|UNKNOWN\\)"
 264                        server-group))
 265                      (ignore-errors
 266                        (gnus-request-head msg-id server-group)))
 267                 (throw 'found server-group))))
 268       (when (featurep 'notmuch)
 269         nil))))
 270
 271 (defun gnorb-collect-ids (&optional id)
 272   "Collect all Org IDs for a subtree.
 273
 274 Starting with the heading under point (or the heading indicated
 275 by the ID argument), collect its ID property, and the IDs of all
 276 child headings."
 277   (save-excursion
 278     (save-restriction
 279       (when id
 280         (org-id-goto id))
 281       (org-narrow-to-subtree)
 282       (org-element-map (org-element-parse-buffer)
 283           'headline
 284         (lambda (hl)
 285           (org-element-property :ID hl))))))
 286
 287 ;; Loading the registry
 288
 289 (defvar gnorb-tracking-enabled nil
 290   "Internal flag indicating whether Gnorb is successfully plugged
 291   into the registry or not.")
 292
 293 (defun gnorb-tracking-initialize ()
 294   "Start using the Gnus registry to track correspondences between
 295 Gnus messages and Org headings. This requires that the Gnus
 296 registry be in use, and should be called after the call to
 297 `gnus-registry-initialize'."
 298   (require 'gnorb-registry)
 299   (add-hook
 300    'gnus-started-hook
 301    (lambda ()
 302      (unless (gnus-registry-install-p)
 303        (user-error "Gnorb tracking requires that the Gnus registry be installed."))
 304      (add-to-list 'gnus-registry-extra-entries-precious 'gnorb-ids)
 305      (add-to-list 'gnus-registry-track-extra 'gnorb-ids)
 306      (add-hook 'org-capture-mode-hook 'gnorb-registry-capture)
 307      (add-hook 'org-capture-prepare-finalize-hook 'gnorb-registry-capture-abort-cleanup)
 308      (setq gnorb-tracking-enabled t))))
 309
 310 (provide 'gnorb-utils)
 311 ;;; gnorb-utils.el ends here