planner-gnus.el

   1 ;;; planner-gnus.el --- Gnus integration for the Emacs Planner
   2
   3 ;; Copyright (C) 2001, 2003, 2004, 2005,
   4 ;;   2006, 2007, 2008 Free Software Foundation, Inc.
   5 ;; Parts copyright (C) 2004, 2008 Mario Domgörgen (kanaldrache AT gmx.de)
   6
   7 ;; Author: John Wiegley <johnw@gnu.org>
   8 ;; Keywords: planner, gnus
   9 ;; URL: http://www.emacswiki.org/cgi-bin/wiki/PlannerMode
  10
  11 ;; This file is part of Planner.  It is not part of GNU Emacs.
  12
  13 ;; Planner is free software; you can redistribute it and/or modify it
  14 ;; under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 3, or (at your option)
  16 ;; any later version.
  17
  18 ;; Planner is distributed in the hope that it will be useful, but
  19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21 ;; General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with Planner; see the file COPYING.  If not, write to the
  25 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  26 ;; Boston, MA 02110-1301, USA.
  27
  28 ;;; Commentary:
  29
  30 ;; This file adds annotations for Gnus messages. ;You will then be
  31 ;; able to use M-x planner-create-task-from-buffer to create tasks
  32 ;; from Gnus summary or message buffers with the correct annotation.
  33 ;; If you add
  34 ;;
  35 ;;     (planner-gnus-insinuate)
  36 ;;
  37 ;; to your .emacs, you can also use 'C-c C-t' to create a task from a buffer.
  38
  39 ;;; Contributors:
  40
  41 ;; Daniel Neri (dne AT mayonnaise DOT net) fixed a few typos and
  42 ;; updated the commentary.
  43
  44 ;; Mario Domgörgen (kanaldrache AT gmx DOT de) got this to work nicely
  45 ;; with multiple marked messages in Gnus summary buffers.
  46
  47 ;; Sven Kloppenburg (kloppenburg AT informatik.tu-darmstadt.de)
  48 ;; provided a patch to use gnus-registry if loaded.
  49
  50 ;; Magnus Henoch (mange AT freemail.hu) provided a patch to add space
  51 ;; after the author's name on newgroups.
  52
  53 ;; Stefan Reichör fixed a problem with getting group names from Gnus.
  54
  55 ;; Yann Hodique fixed a couple of typos.
  56
  57 ;; Dale Smith helped determine the necessary changes for Emacs21
  58 ;; support.
  59
  60 ;;; Code:
  61
  62 (require 'planner)
  63 (require 'gnus)
  64 (require 'gnus-msg)
  65
  66 ;;;###autoload
  67 (defun planner-gnus-insinuate ()
  68   "Hook Planner into Gnus.
  69
  70 Adds special planner keybindings to the variable
  71 `gnus-summary-article-map'. From a summary or article buffer, you
  72 can type C-c C-t to call planner-create-task-from-buffer."
  73   (eval-after-load 'gnus-sum
  74     `(define-key gnus-summary-mode-map ,(kbd "C-c C-t")
  75        'planner-create-task-from-buffer))
  76   (eval-after-load 'gnus
  77     `(define-key gnus-article-mode-map ,(kbd "C-c C-t")
  78        'planner-create-task-from-buffer)))
  79
  80 (require 'gnus-sum)
  81
  82 (defun planner-gnus-get-message-id (&optional article-number)
  83   "Return the message-id of the current message."
  84   (save-excursion
  85     (if (equal major-mode 'gnus-summary-mode)
  86         (let
  87             ((mhmi
  88               (mail-header-message-id (gnus-data-header
  89                                        (assq (or article-number
  90                                                  (gnus-summary-article-number))
  91                                              gnus-newsgroup-data)))))
  92           (if (nnheader-fake-message-id-p mhmi)
  93               (number-to-string article-number)
  94             mhmi))
  95       ;; Refer to the article buffer
  96       (save-excursion
  97         (goto-char (point-min))
  98         (let ((case-fold-search t))
  99           (when (re-search-forward "^Message-ID:\\s-*\\(.+\\)"
 100                                    (point-max) t)
 101             (match-string 1)))))))
 102
 103 (defun planner-gnus-get-address (&optional header)
 104   "Return the address of the sender of the current message.
 105 If HEADER is \"To\", return the recipient instead."
 106   (save-excursion
 107     (goto-char (point-min))
 108     (let ((case-fold-search t))
 109       (when (re-search-forward
 110              (concat "^" (or header "From") ":\\s-*\\(.+\\)")
 111              (point-max) t)
 112         (planner-match-string-no-properties 1)))))
 113
 114 (defun planner-gnus-annotation-from-summary ()
 115   "If called from a Gnus summary buffer, return an annotation.
 116 Suitable for use in `planner-annotation-functions'."
 117   (when (equal major-mode 'gnus-summary-mode)
 118     (let ((articles (gnus-summary-work-articles nil)))
 119       (planner-make-link
 120        (concat "gnus://" gnus-newsgroup-name "/"
 121                (mapconcat (lambda (article-number)
 122                             (planner-gnus-get-message-id article-number))
 123                           (gnus-summary-work-articles nil) "\\|"))
 124        (if (= 1 (length articles))
 125            (let ((headers (gnus-data-header (assq (car articles)
 126                                                   gnus-newsgroup-data))))
 127              (if (gnus-news-group-p gnus-newsgroup-name)
 128                  (concat "Post "
 129                          (if (and planner-ignored-from-addresses
 130                                   (string-match
 131                                    planner-ignored-from-addresses
 132                                    (mail-header-from headers)))
 133                              ""
 134                            (concat "from "
 135                                    (planner-get-name-from-address
 136                                     (mail-header-from headers))
 137                                    " "))
 138                          "on "
 139                          gnus-newsgroup-name)
 140                (concat "E-Mail "
 141                        (if (and planner-ignored-from-addresses
 142                                 (mail-header-from headers)
 143                                 (string-match planner-ignored-from-addresses
 144                                               (mail-header-from headers))
 145                                 (assq 'To
 146                                       (mail-header-extra headers)))
 147                            ;; Mail from me, so use the To: instead
 148                            (concat "to " (planner-get-name-from-address
 149                                           (cdr (assq 'To
 150                                                      (mail-header-extra
 151                                                       headers)))))
 152                          ;; Mail to me, so use the From:
 153                          (concat "from " (planner-get-name-from-address
 154                                           (mail-header-from headers)))))))
 155          (concat (number-to-string (length articles))
 156                  " E-Mails from folder " gnus-newsgroup-name))
 157        t))))
 158
 159 (defun planner-gnus-annotation-from-message ()
 160   "If called from a Gnus article, return an annotation.
 161 Suitable for use in `planner-annotation-functions'."
 162   (when (or (equal major-mode 'gnus-article-mode)
 163             (equal major-mode 'gnus-original-article-mode))
 164     (gnus-copy-article-buffer)
 165     (with-current-buffer gnus-article-copy
 166       (let ((from (planner-gnus-get-address "From"))
 167             (newsgroups (planner-gnus-get-address "Newsgroups")))
 168         (planner-make-link
 169          (concat "gnus://" gnus-newsgroup-name "/"
 170                  (planner-gnus-get-message-id))
 171          (if newsgroups
 172              (concat "Post "
 173                      (if (and planner-ignored-from-addresses
 174                               (string-match
 175                                planner-ignored-from-addresses from))
 176                          ""
 177                        (concat "from "
 178                                (planner-get-name-from-address from)
 179                                " "))
 180                      "on "
 181                      newsgroups)
 182            (concat "E-Mail "
 183                    (let ((to-addr
 184                           (planner-gnus-get-address "To")))
 185                      (if (and planner-ignored-from-addresses
 186                               from
 187                               to-addr
 188                               (string-match
 189                                planner-ignored-from-addresses from))
 190                          (concat "to " (planner-get-name-from-address
 191                                         to-addr))
 192                        (concat "from " (planner-get-name-from-address
 193                                         from))))))
 194          t)))))
 195
 196 ;;;###autoload
 197 (defun planner-gnus-annotation ()
 198   "Return an annotation from a Gnus summary or message buffer.
 199 Suitable for use in `planner-annotation-functions'. If you
 200 include this, you can omit `planner-gnus-annotation-from-summary'
 201 and `planner-gnus-annotation-from-message'."
 202   (or (planner-gnus-annotation-from-summary)
 203       (planner-gnus-annotation-from-message)))
 204
 205 (defvar planner-gnus-group-threshold 10
 206   "Number of messages to retrieve from groups.
 207 Raise this if you have problems browsing gnus URLs.")
 208
 209 ;;;###autoload
 210 (defun planner-gnus-browse-url (url)
 211   "If this is a Gnus URL, jump to it."
 212   (when (string-match "\\`gnus://\\(.+\\)/\\(.+\\)" url)
 213     (let ((group (match-string 1 url))
 214           (articles (match-string 2 url)))
 215       (when (featurep 'gnus-registry)
 216         (let ((reg-group (gnus-registry-fetch-group articles)))
 217           (when reg-group
 218             (if gnus-registry-use-long-group-names
 219                 (setq group reg-group)
 220               (when (cadr (split-string group ":")) ;; group contains a :
 221                 (setq group (concat (car (split-string group ":")) ":"
 222                                     reg-group)))))))
 223       ;; Don't automatically select an article, as that might mark
 224       ;; unread articles as read.
 225       (let ((gnus-auto-select-first nil))
 226         (condition-case err
 227             (gnus-fetch-group group planner-gnus-group-threshold t group)
 228           (error (gnus-fetch-group group))))
 229       (mapcar
 230        (lambda (article-id)
 231          (gnus-summary-goto-article article-id nil t))
 232        (split-string articles "\\\\|"))
 233       (let ((articles (if (fboundp 'gnus-find-matching-articles)
 234                           (gnus-find-matching-articles "message-id" articles)
 235                         (gnus-summary-find-matching "message-id" articles
 236                                                     nil nil t))))
 237         (gnus-summary-limit articles)
 238         (gnus-summary-select-article))
 239       t)))
 240
 241 (fset 'planner-get-from 'planner-gnus-get-address)
 242 (fset 'planner-get-message-id 'planner-gnus-get-message-id)
 243 (custom-add-option 'planner-annotation-functions
 244                    'planner-gnus-annotation)
 245 (add-hook 'planner-annotation-functions 'planner-gnus-annotation)
 246 (planner-add-protocol "gnus://" 'planner-gnus-browse-url nil)
 247
 248 (provide 'planner-gnus)
 249
 250 ;;; planner-gnus.el ends here