lisp/org/org-gnus.el

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