planner-gnus.el

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