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