planner-gnus.el

   1 ;;; planner-gnus.el --- Gnus integration for the Emacs Planner
   2
   3 ;; Copyright (C) 2001, 2003, 2004, 2005,
   4 ;;   2006 Free Software Founation, Inc.
   5 ;; Parts copyright (C) 2004 Mario Domgörgen (kanaldrache AT gmx.de)
   6
   7 ;; Author: John Wiegley <johnw@gnu.org>
   8 ;; Keywords: planner, gnus
   9 ;; URL: http://www.plannerlove.com/
  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 2, 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-article-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         (mail-header-message-id (gnus-data-header
  87                                  (assq (or article-number
  88                                            (gnus-summary-article-number))
  89                                        gnus-newsgroup-data)))
  90       ;; Refer to the article buffer
  91       (save-excursion
  92         (goto-char (point-min))
  93         (let ((case-fold-search t))
  94           (when (re-search-forward "^Message-ID:\\s-*\\(.+\\)"
  95                                    (point-max) t)
  96             (match-string 1)))))))
  97
  98 (defun planner-gnus-get-address (&optional header)
  99   "Return the address of the sender of the current message.
 100 If HEADER is \"To\", return the recipient instead."
 101   (save-excursion
 102     (goto-char (point-min))
 103     (let ((case-fold-search t))
 104       (when (re-search-forward
 105              (concat "^" (or header "From") ":\\s-*\\(.+\\)")
 106              (point-max) t)
 107         (planner-match-string-no-properties 1)))))
 108
 109 (defun planner-gnus-annotation-from-summary ()
 110   "If called from a Gnus summary buffer, return an annotation.
 111 Suitable for use in `planner-annotation-functions'."
 112   (when (equal major-mode 'gnus-summary-mode)
 113     (let ((articles (gnus-summary-work-articles nil)))
 114       (planner-make-link
 115        (concat "gnus://" gnus-newsgroup-name "/"
 116                (mapconcat (lambda (article-number)
 117                             (planner-gnus-get-message-id article-number))
 118                           (gnus-summary-work-articles nil) "\\|"))
 119        (if (= 1 (length articles))
 120            (let ((headers (gnus-data-header (assq (car articles)
 121                                                   gnus-newsgroup-data))))
 122              (if (gnus-news-group-p gnus-newsgroup-name)
 123                  (concat "Post "
 124                          (if (and planner-ignored-from-addresses
 125                                   (string-match
 126                                    planner-ignored-from-addresses
 127                                    (mail-header-from headers)))
 128                              ""
 129                            (concat "from "
 130                                    (planner-get-name-from-address
 131                                     (mail-header-from headers))
 132                                    " "))
 133                          "on "
 134                          gnus-newsgroup-name)
 135                (concat "E-Mail "
 136                        (if (and planner-ignored-from-addresses
 137                                 (mail-header-from headers)
 138                                 (string-match planner-ignored-from-addresses
 139                                               (mail-header-from headers))
 140                                 (assq 'To
 141                                       (mail-header-extra headers)))
 142                            ;; Mail from me, so use the To: instead
 143                            (concat "to " (planner-get-name-from-address
 144                                           (cdr (assq 'To
 145                                                      (mail-header-extra
 146                                                       headers)))))
 147                          ;; Mail to me, so use the From:
 148                          (concat "from " (planner-get-name-from-address
 149                                           (mail-header-from headers)))))))
 150          (concat (number-to-string (length articles))
 151                  " E-Mails from folder " gnus-newsgroup-name))
 152        t))))
 153
 154 (defun planner-gnus-annotation-from-message ()
 155   "If called from a Gnus article, return an annotation.
 156 Suitable for use in `planner-annotation-functions'."
 157   (when (or (equal major-mode 'gnus-article-mode)
 158             (equal major-mode 'gnus-original-article-mode))
 159     (gnus-copy-article-buffer)
 160     (with-current-buffer gnus-article-copy
 161       (let ((from (planner-gnus-get-address "From"))
 162             (newsgroups (planner-gnus-get-address "Newsgroups")))
 163         (planner-make-link
 164          (concat "gnus://" gnus-newsgroup-name "/"
 165                  (planner-gnus-get-message-id))
 166          (if newsgroups
 167              (concat "Post "
 168                      (if (and planner-ignored-from-addresses
 169                               (string-match
 170                                planner-ignored-from-addresses from))
 171                          ""
 172                        (concat "from "
 173                                (planner-get-name-from-address from)
 174                                " "))
 175                      "on "
 176                      newsgroups)
 177            (concat "E-Mail "
 178                    (let ((to-addr
 179                           (planner-gnus-get-address "To")))
 180                      (if (and planner-ignored-from-addresses
 181                               from
 182                               to-addr
 183                               (string-match
 184                                planner-ignored-from-addresses from))
 185                          (concat "to " (planner-get-name-from-address
 186                                         to-addr))
 187                        (concat "from " (planner-get-name-from-address
 188                                         from))))))
 189          t)))))
 190
 191 ;;;###autoload
 192 (defun planner-gnus-annotation ()
 193   "Return an annotation from a Gnus summary or message buffer.
 194 Suitable for use in `planner-annotation-functions'. If you
 195 include this, you can omit `planner-gnus-annotation-from-summary'
 196 and `planner-gnus-annotation-from-message'."
 197   (or (planner-gnus-annotation-from-summary)
 198       (planner-gnus-annotation-from-message)))
 199
 200 (defvar planner-gnus-group-threshold 10
 201   "Number of messages to retrieve from groups.
 202 Raise this if you have problems browsing gnus URLs.")
 203
 204 ;;;###autoload
 205 (defun planner-gnus-browse-url (url)
 206   "If this is a Gnus URL, jump to it."
 207   (when (string-match "\\`gnus://\\(.+\\)/\\(.+\\)" url)
 208     (let ((group (match-string 1 url))
 209           (articles (match-string 2 url)))
 210       (when (featurep 'gnus-registry)
 211         (let ((reg-group (gnus-registry-fetch-group articles)))
 212           (when reg-group
 213             (if gnus-registry-use-long-group-names
 214                 (setq group reg-group)
 215               (when (cadr (split-string group ":")) ;; group contains a :
 216                 (setq group (concat (car (split-string group ":")) ":"
 217                                     reg-group)))))))
 218       (condition-case err
 219           (gnus-fetch-group group planner-gnus-group-threshold)
 220         (error (gnus-fetch-group group)))
 221       (mapcar
 222        (lambda (article-id)
 223          (gnus-summary-goto-article article-id nil t))
 224        (split-string articles "\\\\|"))
 225       (let ((articles (if (fboundp 'gnus-find-matching-articles)
 226                           (gnus-find-matching-articles "message-id" articles)
 227                         (gnus-summary-find-matching "message-id" articles
 228                                                     nil nil t))))
 229         (gnus-summary-limit articles)
 230         (gnus-summary-select-article))
 231       t)))
 232
 233 (fset 'planner-get-from 'planner-gnus-get-address)
 234 (fset 'planner-get-message-id 'planner-gnus-get-message-id)
 235 (custom-add-option 'planner-annotation-functions
 236                    'planner-gnus-annotation)
 237 (add-hook 'planner-annotation-functions 'planner-gnus-annotation)
 238 (planner-add-protocol "gnus://" 'planner-gnus-browse-url nil)
 239
 240 (provide 'planner-gnus)
 241
 242 ;;; planner-gnus.el ends here