lisp/org-gnus.el

   1 ;;; org-gnus.el --- Support for links to Gnus groups and messages from within Org-mode
   2
   3 ;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010
   4 ;;   Free Software Foundation, Inc.
   5
   6 ;; Author: Carsten Dominik <carsten at orgmode dot org>
   7 ;;         Tassilo Horn <tassilo at member dot fsf dot org>
   8 ;; Keywords: outlines, hypermedia, calendar, wp
   9 ;; Homepage: http://orgmode.org
  10 ;; Version: 7.01trans
  11 ;;
  12 ;; This file is part of GNU Emacs.
  13 ;;
  14 ;; GNU Emacs is free software: you can redistribute it and/or modify
  15 ;; it under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation, either version 3 of the License, or
  17 ;; (at your option) any later version.
  18
  19 ;; GNU Emacs is distributed in the hope that it will be useful,
  20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;; GNU General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27 ;;
  28 ;;; Commentary:
  29
  30 ;; This file implements links to Gnus groups and messages from within Org-mode.
  31 ;; Org-mode loads this module by default - if this is not what you want,
  32 ;; configure the variable `org-modules'.
  33
  34 ;;; Code:
  35
  36 (require 'org)
  37 (eval-when-compile (require 'gnus-sum))
  38
  39 ;; Declare external functions and variables
  40 (declare-function message-fetch-field "message" (header &optional not-all))
  41 (declare-function message-narrow-to-head-1 "message" nil)
  42 ;; The following line suppresses a compiler warning stemming from gnus-sum.el
  43 (declare-function gnus-summary-last-subject "gnus-sum" nil)
  44 ;; Suppress compiler warning
  45 (declare-function nnimap-retrieve-headers-from-file "nnimap" nil)
  46 ;; Customization variables
  47
  48 (when (fboundp 'defvaralias)
  49   (defvaralias 'org-usenet-links-prefer-google 'org-gnus-prefer-web-links))
  50
  51 (defcustom org-gnus-prefer-web-links nil
  52   "If non-nil, `org-store-link' creates web links to Google groups or Gmane.
  53 When nil, Gnus will be used for such links.
  54 Using a prefix arg to the command \\[org-store-link] (`org-store-link')
  55 negates this setting for the duration of the command."
  56   :group 'org-link-store
  57   :type 'boolean)
  58
  59 (defcustom org-gnus-nnimap-query-article-no-from-file nil
  60   "If non-nil, `org-gnus-follow-link' will try to translate
  61 Message-Ids to article numbers by querying the .overview file.
  62 Normally, this translation is done by querying the IMAP server,
  63 which is usually very fast.  Unfortunately, some (maybe badly
  64 configured) IMAP servers don't support this operation quickly.
  65 So if following a link to a Gnus article takes ages, try setting
  66 this variable to `t'."
  67   :group 'org-link-store
  68   :type 'boolean)
  69
  70 ;; Install the link type
  71 (org-add-link-type "gnus" 'org-gnus-open)
  72 (add-hook 'org-store-link-functions 'org-gnus-store-link)
  73
  74 ;; Implementation
  75
  76 (defun org-gnus-group-link (group)
  77   "Create a link to the Gnus group GROUP.
  78 If GROUP is a newsgroup and `org-gnus-prefer-web-links' is
  79 non-nil, create a link to groups.google.com or gmane.org.
  80 Otherwise create a link to the group inside Gnus.
  81
  82 If `org-store-link' was called with a prefix arg the meaning of
  83 `org-gnus-prefer-web-links' is reversed."
  84   (let ((unprefixed-group (replace-regexp-in-string "^[^:]+:" "" group)))
  85     (if (and (string-match "^nntp" group) ;; Only for nntp groups
  86              (org-xor current-prefix-arg
  87                       org-gnus-prefer-web-links))
  88         (org-make-link (if (string-match "gmane" unprefixed-group)
  89                            "http://news.gmane.org/"
  90                          "http://groups.google.com/group/")
  91                        unprefixed-group)
  92       (org-make-link "gnus:" group))))
  93
  94 (defun org-gnus-article-link (group newsgroups message-id x-no-archive)
  95   "Create a link to a Gnus article.
  96 The article is specified by its MESSAGE-ID.  Additional
  97 parameters are the Gnus GROUP, the NEWSGROUPS the article was
  98 posted to and the X-NO-ARCHIVE header value of that article.
  99
 100 If GROUP is a newsgroup and `org-gnus-prefer-web-links' is
 101 non-nil, create a link to groups.google.com or gmane.org.
 102 Otherwise create a link to the article inside Gnus.
 103
 104 If `org-store-link' was called with a prefix arg the meaning of
 105 `org-gnus-prefer-web-links' is reversed."
 106   (if (and (org-xor current-prefix-arg org-gnus-prefer-web-links)
 107            newsgroups     ;; Make web links only for nntp groups
 108            (not x-no-archive)) ;; and if X-No-Archive isn't set.
 109       (format (if (string-match "gmane\\." newsgroups)
 110                   "http://mid.gmane.org/%s"
 111                 "http://groups.google.com/groups/search?as_umsgid=%s")
 112               (org-fixup-message-id-for-http message-id))
 113     (org-make-link "gnus:" group "#" message-id)))
 114
 115 (defun org-gnus-store-link ()
 116   "Store a link to a Gnus folder or message."
 117   (cond
 118    ((eq major-mode 'gnus-group-mode)
 119     (let* ((group (cond ((fboundp 'gnus-group-group-name) ; depending on Gnus
 120                          (gnus-group-group-name))         ; version
 121                         ((fboundp 'gnus-group-name)
 122                          (gnus-group-name))
 123                         (t "???")))
 124            desc link)
 125       (when group
 126         (org-store-link-props :type "gnus" :group group)
 127         (setq desc (org-gnus-group-link group)
 128               link desc)
 129         (org-add-link-props :link link :description desc)
 130         link)))
 131
 132    ((memq major-mode '(gnus-summary-mode gnus-article-mode))
 133     (let* ((group gnus-newsgroup-name)
 134            (header (with-current-buffer gnus-summary-buffer
 135                      (gnus-summary-article-header)))
 136            (from (mail-header-from header))
 137            (message-id (org-remove-angle-brackets (mail-header-id header)))
 138            (date (mail-header-date header))
 139            (subject (copy-sequence (mail-header-subject header)))
 140            (to (cdr (assq 'To (mail-header-extra header))))
 141            newsgroups x-no-archive desc link)
 142       ;; Remove text properties of subject string to avoid Emacs bug
 143       ;; #3506
 144       (set-text-properties 0 (length subject) nil subject)
 145
 146       ;; Fetching an article is an expensive operation; newsgroup and
 147       ;; x-no-archive are only needed for web links.
 148       (when (org-xor current-prefix-arg org-gnus-prefer-web-links)
 149         ;; Make sure the original article buffer is up-to-date
 150         (save-window-excursion (gnus-summary-select-article))
 151         (setq to (or to (gnus-fetch-original-field "To"))
 152               newsgroups (gnus-fetch-original-field "Newsgroups")
 153               x-no-archive (gnus-fetch-original-field "x-no-archive")))
 154       (org-store-link-props :type "gnus" :from from :subject subject
 155                             :message-id message-id :group group :to to)
 156       (setq desc (org-email-link-description)
 157             link (org-gnus-article-link
 158                   group newsgroups message-id x-no-archive))
 159       (org-add-link-props :link link :description desc)
 160       link))))
 161
 162 (defun org-gnus-open (path)
 163   "Follow the Gnus message or folder link specified by PATH."
 164   (let (group article)
 165     (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path))
 166         (error "Error in Gnus link"))
 167     (setq group (match-string 1 path)
 168           article (match-string 3 path))
 169     (when group
 170       (setq group (org-substring-no-properties group)))
 171     (when article
 172       (setq article (org-substring-no-properties article)))
 173     (org-gnus-follow-link group article)))
 174
 175 (defun org-gnus-follow-link (&optional group article)
 176   "Follow a Gnus link to GROUP and ARTICLE."
 177   (require 'gnus)
 178   (funcall (cdr (assq 'gnus org-link-frame-setup)))
 179   (if gnus-other-frame-object (select-frame gnus-other-frame-object))
 180   (when group
 181     (setq group (org-substring-no-properties group)))
 182   (when article
 183     (setq article (org-substring-no-properties article)))
 184   (cond ((and group article)
 185          (gnus-activate-group group t)
 186          (condition-case nil
 187              (let* ((method (gnus-find-method-for-group group))
 188                     (backend (car method))
 189                     (server (cadr method)))
 190                (message "method = %s\ngroup = %s\nbackend = %s\nserver = %s"
 191                         method group backend server)
 192                (cond
 193                 ((eq backend 'nndoc)
 194                  (if (gnus-group-read-group t nil group)
 195                      (gnus-summary-goto-article article nil t)
 196                    (message "Couldn't follow gnus link.  %s"
 197                             "The summary couldn't be opened.")))
 198                 (t
 199                  (let ((articles 1)
 200                        group-opened)
 201                    ;; work arround IMAP servers that perform badly in
 202                    ;; SEARCH commands.
 203                    (when (and (eq backend 'nnimap)
 204                               org-gnus-nnimap-query-article-no-from-file)
 205                      (let ((headers (nnimap-retrieve-headers-from-file group server)))
 206                        (message "headers = %s" headers)))
 207                    (while (and (not group-opened)
 208                                ;; stop on integer overflows
 209                                (> articles 0))
 210                      (setq group-opened (gnus-group-read-group
 211                                          articles nil group)
 212                            articles (if (< articles 16)
 213                                         (1+ articles)
 214                                       (* articles 2))))
 215                    (if group-opened
 216                        (gnus-summary-goto-article article nil t)
 217                      (message "Couldn't follow gnus link.  %s"
 218                               "The summary couldn't be opened."))))))
 219            (quit (message "Couldn't follow gnus link.  %s"
 220                           "The linked group is empty."))))
 221         (group (gnus-group-jump-to-group group))))
 222
 223 (defun org-gnus-no-new-news ()
 224   "Like `M-x gnus' but doesn't check for new news."
 225   (if (not (gnus-alive-p)) (gnus)))
 226
 227 (provide 'org-gnus)
 228
 229 ;; arch-tag: 512e0840-58fa-45b3-b456-71e10fa2376d
 230
 231 ;;; org-gnus.el ends here