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.4
  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 (declare-function nnimap-group-overview-filename "nnimap" (group server))
  43 ;; The following line suppresses a compiler warning stemming from gnus-sum.el
  44 (declare-function gnus-summary-last-subject "gnus-sum" nil)
  45 ;; Customization variables
  46
  47 (when (fboundp 'defvaralias)
  48   (defvaralias 'org-usenet-links-prefer-google 'org-gnus-prefer-web-links))
  49
  50 (defcustom org-gnus-prefer-web-links nil
  51   "If non-nil, `org-store-link' creates web links to Google groups or Gmane.
  52 When nil, Gnus will be used for such links.
  53 Using a prefix arg to the command \\[org-store-link] (`org-store-link')
  54 negates this setting for the duration of the command."
  55   :group 'org-link-store
  56   :type 'boolean)
  57
  58 (defcustom org-gnus-nnimap-query-article-no-from-file nil
  59   "If non-nil, `org-gnus-follow-link' will try to translate
  60 Message-Ids to article numbers by querying the .overview file.
  61 Normally, this translation is done by querying the IMAP server,
  62 which is usually very fast.  Unfortunately, some (maybe badly
  63 configured) IMAP servers don't support this operation quickly.
  64 So if following a link to a Gnus article takes ages, try setting
  65 this variable to `t'."
  66   :group 'org-link-store
  67   :type 'boolean)
  68
  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-nnimap-cached-article-number (group server message-id)
  77   "Return cached article number (uid) of message in GROUP on SERVER.
  78 MESSAGE-ID is the message-id header field that identifies the
  79 message.  If the uid is not cached, return nil."
  80   (with-temp-buffer
  81     (let ((nov (nnimap-group-overview-filename group server)))
  82       (when (file-exists-p nov)
  83         (mm-insert-file-contents nov)
  84         (set-buffer-modified-p nil)
  85         (goto-char (point-min))
  86         (catch 'found
  87           (while (search-forward message-id nil t)
  88             (let ((hdr (split-string (thing-at-point 'line) "\t")))
  89               (if (string= (nth 4 hdr) message-id)
  90                   (throw 'found (nth 0 hdr))))))))))
  91
  92 (defun org-gnus-group-link (group)
  93   "Create a link to the Gnus group GROUP.
  94 If GROUP is a newsgroup and `org-gnus-prefer-web-links' is
  95 non-nil, create a link to groups.google.com or gmane.org.
  96 Otherwise create a link to the group inside Gnus.
  97
  98 If `org-store-link' was called with a prefix arg the meaning of
  99 `org-gnus-prefer-web-links' is reversed."
 100   (let ((unprefixed-group (replace-regexp-in-string "^[^:]+:" "" group)))
 101     (if (and (string-match "^nntp" group) ;; Only for nntp groups
 102              (org-xor current-prefix-arg
 103                       org-gnus-prefer-web-links))
 104         (org-make-link (if (string-match "gmane" unprefixed-group)
 105                            "http://news.gmane.org/"
 106                          "http://groups.google.com/group/")
 107                        unprefixed-group)
 108       (org-make-link "gnus:" group))))
 109
 110 (defun org-gnus-article-link (group newsgroups message-id x-no-archive)
 111   "Create a link to a Gnus article.
 112 The article is specified by its MESSAGE-ID.  Additional
 113 parameters are the Gnus GROUP, the NEWSGROUPS the article was
 114 posted to and the X-NO-ARCHIVE header value of that article.
 115
 116 If GROUP is a newsgroup and `org-gnus-prefer-web-links' is
 117 non-nil, create a link to groups.google.com or gmane.org.
 118 Otherwise create a link to the article inside Gnus.
 119
 120 If `org-store-link' was called with a prefix arg the meaning of
 121 `org-gnus-prefer-web-links' is reversed."
 122   (if (and (org-xor current-prefix-arg org-gnus-prefer-web-links)
 123            newsgroups     ;; Make web links only for nntp groups
 124            (not x-no-archive)) ;; and if X-No-Archive isn't set.
 125       (format (if (string-match "gmane\\." newsgroups)
 126                   "http://mid.gmane.org/%s"
 127                 "http://groups.google.com/groups/search?as_umsgid=%s")
 128               (org-fixup-message-id-for-http message-id))
 129     (org-make-link "gnus:" group "#" message-id)))
 130
 131 (defun org-gnus-store-link ()
 132   "Store a link to a Gnus folder or message."
 133   (cond
 134    ((eq major-mode 'gnus-group-mode)
 135     (let* ((group (cond ((fboundp 'gnus-group-group-name) ; depending on Gnus
 136                          (gnus-group-group-name))         ; version
 137                         ((fboundp 'gnus-group-name)
 138                          (gnus-group-name))
 139                         (t "???")))
 140            desc link)
 141       (when group
 142         (org-store-link-props :type "gnus" :group group)
 143         (setq desc (org-gnus-group-link group)
 144               link desc)
 145         (org-add-link-props :link link :description desc)
 146         link)))
 147
 148    ((memq major-mode '(gnus-summary-mode gnus-article-mode))
 149     (let* ((group gnus-newsgroup-name)
 150            (header (with-current-buffer gnus-summary-buffer
 151                      (gnus-summary-article-header)))
 152            (from (mail-header-from header))
 153            (message-id (org-remove-angle-brackets (mail-header-id header)))
 154            (date (org-trim (mail-header-date header)))
 155            (date-ts (and date
 156                          (ignore-errors
 157                            (format-time-string
 158                             (org-time-stamp-format t)
 159                             (date-to-time date)))))
 160            (date-ts-ia (and date
 161                             (ignore-errors
 162                               (format-time-string
 163                                (org-time-stamp-format t t)
 164                                (date-to-time date)))))
 165            (subject (copy-sequence (mail-header-subject header)))
 166            (to (cdr (assq 'To (mail-header-extra header))))
 167            newsgroups x-no-archive desc link)
 168       ;; Remove text properties of subject string to avoid Emacs bug
 169       ;; #3506
 170       (set-text-properties 0 (length subject) nil subject)
 171
 172       ;; Fetching an article is an expensive operation; newsgroup and
 173       ;; x-no-archive are only needed for web links.
 174       (when (org-xor current-prefix-arg org-gnus-prefer-web-links)
 175         ;; Make sure the original article buffer is up-to-date
 176         (save-window-excursion (gnus-summary-select-article))
 177         (setq to (or to (gnus-fetch-original-field "To"))
 178               newsgroups (gnus-fetch-original-field "Newsgroups")
 179               x-no-archive (gnus-fetch-original-field "x-no-archive")))
 180       (org-store-link-props :type "gnus" :from from :subject subject
 181                             :message-id message-id :group group :to to)
 182       (when date
 183         (org-add-link-props :date date :date-timestamp date-ts
 184                             :date-timestamp-inactive date-ts-ia))
 185       (setq desc (org-email-link-description)
 186             link (org-gnus-article-link
 187                   group newsgroups message-id x-no-archive))
 188       (org-add-link-props :link link :description desc)
 189       link))))
 190
 191 (defun org-gnus-open-nntp (path)
 192   "Follow the nntp: link specified by PATH."
 193   (let* ((spec (split-string path "/"))
 194          (server (split-string (nth 2 spec) "@"))
 195          (group (nth 3 spec))
 196          (article (nth 4 spec)))
 197     (org-gnus-follow-link
 198      (format "nntp+%s:%s" (or (cdr server) (car server)) group)
 199      article)))
 200
 201 (defun org-gnus-open (path)
 202   "Follow the Gnus message or folder link specified by PATH."
 203   (let (group article)
 204     (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path))
 205         (error "Error in Gnus link"))
 206     (setq group (match-string 1 path)
 207           article (match-string 3 path))
 208     (when group
 209       (setq group (org-substring-no-properties group)))
 210     (when article
 211       (setq article (org-substring-no-properties article)))
 212     (org-gnus-follow-link group article)))
 213
 214 (defun org-gnus-follow-link (&optional group article)
 215   "Follow a Gnus link to GROUP and ARTICLE."
 216   (require 'gnus)
 217   (funcall (cdr (assq 'gnus org-link-frame-setup)))
 218   (if gnus-other-frame-object (select-frame gnus-other-frame-object))
 219   (when group
 220     (setq group (org-substring-no-properties group)))
 221   (when article
 222     (setq article (org-substring-no-properties article)))
 223   (cond ((and group article)
 224          (gnus-activate-group group t)
 225          (condition-case nil
 226              (let* ((method (gnus-find-method-for-group group))
 227                     (backend (car method))
 228                     (server (cadr method)))
 229                (cond
 230                 ((eq backend 'nndoc)
 231                  (if (gnus-group-read-group t nil group)
 232                      (gnus-summary-goto-article article nil t)
 233                    (message "Couldn't follow gnus link.  %s"
 234                             "The summary couldn't be opened.")))
 235                 (t
 236                  (let ((articles 1)
 237                        group-opened)
 238                    (when (and (eq backend 'nnimap)
 239                               org-gnus-nnimap-query-article-no-from-file)
 240                      (setq article
 241                            (or (org-gnus-nnimap-cached-article-number
 242                                 (nth 1 (split-string group ":"))
 243                                 server (concat "<" article ">")) article)))
 244                    (while (and (not group-opened)
 245                                ;; stop on integer overflows
 246                                (> articles 0))
 247                      (setq group-opened (gnus-group-read-group
 248                                          articles nil group)
 249                            articles (if (< articles 16)
 250                                         (1+ articles)
 251                                       (* articles 2))))
 252                    (if group-opened
 253                        (gnus-summary-goto-article article nil t)
 254                      (message "Couldn't follow gnus link.  %s"
 255                               "The summary couldn't be opened."))))))
 256            (quit (message "Couldn't follow gnus link.  %s"
 257                           "The linked group is empty."))))
 258         (group (gnus-group-jump-to-group group))))
 259
 260 (defun org-gnus-no-new-news ()
 261   "Like `M-x gnus' but doesn't check for new news."
 262   (if (not (gnus-alive-p)) (gnus)))
 263
 264 (provide 'org-gnus)
 265
 266 ;; arch-tag: 512e0840-58fa-45b3-b456-71e10fa2376d
 267
 268 ;;; org-gnus.el ends here