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