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-2016 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 (require 'gnus-util)
  36 (eval-when-compile (require 'gnus-sum))
  37
  38 ;; Declare external functions and variables
  39
  40 (declare-function message-fetch-field "message" (header &optional not-all))
  41 (declare-function message-narrow-to-head-1 "message" nil)
  42 (declare-function gnus-summary-last-subject "gnus-sum" nil)
  43 (declare-function nnvirtual-map-article "nnvirtual" (article))
  44
  45 ;; Customization variables
  46
  47 (org-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   :version "24.1"
  67   :type 'boolean)
  68
  69 (defcustom org-gnus-no-server nil
  70   "Should Gnus be started using `gnus-no-server'?"
  71   :group 'org-gnus
  72   :version "24.4"
  73   :package-version '(Org . "8.0")
  74   :type 'boolean)
  75
  76 ;; Install the link type
  77 (org-add-link-type "gnus" 'org-gnus-open)
  78 (add-hook 'org-store-link-functions 'org-gnus-store-link)
  79
  80 ;; Implementation
  81
  82 (defun org-gnus-nnimap-cached-article-number (group server message-id)
  83   "Return cached article number (uid) of message in GROUP on SERVER.
  84 MESSAGE-ID is the message-id header field that identifies the
  85 message.  If the uid is not cached, return nil."
  86   (with-temp-buffer
  87     (let ((nov (and (fboundp 'nnimap-group-overview-filename)
  88                     ;; nnimap-group-overview-filename was removed from
  89                     ;; Gnus in September 2010, and therefore should
  90                     ;; only be present in Emacs 23.1.
  91                     (nnimap-group-overview-filename group server))))
  92       (when (and nov (file-exists-p nov))
  93         (mm-insert-file-contents nov)
  94         (set-buffer-modified-p nil)
  95         (goto-char (point-min))
  96         (catch 'found
  97           (while (search-forward message-id nil t)
  98             (let ((hdr (split-string (thing-at-point 'line) "\t")))
  99               (if (string= (nth 4 hdr) message-id)
 100                   (throw 'found (nth 0 hdr))))))))))
 101
 102 (defun org-gnus-group-link (group)
 103   "Create a link to the Gnus group GROUP.
 104 If GROUP is a newsgroup and `org-gnus-prefer-web-links' is
 105 non-nil, create a link to groups.google.com or gmane.org.
 106 Otherwise create a link to the group inside Gnus.
 107
 108 If `org-store-link' was called with a prefix arg the meaning of
 109 `org-gnus-prefer-web-links' is reversed."
 110   (let ((unprefixed-group (replace-regexp-in-string "^[^:]+:" "" group)))
 111     (if (and (string-match "^nntp" group) ;; Only for nntp groups
 112              (org-xor current-prefix-arg
 113                       org-gnus-prefer-web-links))
 114         (concat (if (string-match "gmane" unprefixed-group)
 115                     "http://news.gmane.org/"
 116                   "http://groups.google.com/group/")
 117                 unprefixed-group)
 118       (concat "gnus:" group))))
 119
 120 (defun org-gnus-article-link (group newsgroups message-id x-no-archive)
 121   "Create a link to a Gnus article.
 122 The article is specified by its MESSAGE-ID.  Additional
 123 parameters are the Gnus GROUP, the NEWSGROUPS the article was
 124 posted to and the X-NO-ARCHIVE header value of that article.
 125
 126 If GROUP is a newsgroup and `org-gnus-prefer-web-links' is
 127 non-nil, create a link to groups.google.com or gmane.org.
 128 Otherwise create a link to the article inside Gnus.
 129
 130 If `org-store-link' was called with a prefix arg the meaning of
 131 `org-gnus-prefer-web-links' is reversed."
 132   (if (and (org-xor current-prefix-arg org-gnus-prefer-web-links)
 133            newsgroups     ;; Make web links only for nntp groups
 134            (not x-no-archive)) ;; and if X-No-Archive isn't set.
 135       (format (if (string-match "gmane\\." newsgroups)
 136                   "http://mid.gmane.org/%s"
 137                 "http://groups.google.com/groups/search?as_umsgid=%s")
 138               (org-fixup-message-id-for-http message-id))
 139     (concat "gnus:" group "#" message-id)))
 140
 141 (defun org-gnus-store-link ()
 142   "Store a link to a Gnus folder or message."
 143   (cond
 144    ((eq major-mode 'gnus-group-mode)
 145     (let* ((group (cond ((fboundp 'gnus-group-group-name) ; depending on Gnus
 146                          (gnus-group-group-name))         ; version
 147                         ((fboundp 'gnus-group-name)
 148                          (gnus-group-name))
 149                         (t "???")))
 150            desc link)
 151       (when group
 152         (org-store-link-props :type "gnus" :group group)
 153         (setq desc (org-gnus-group-link group)
 154               link desc)
 155         (org-add-link-props :link link :description desc)
 156         link)))
 157
 158    ((memq major-mode '(gnus-summary-mode gnus-article-mode))
 159     (let* ((group gnus-newsgroup-name)
 160            (header (with-current-buffer gnus-summary-buffer
 161                      (gnus-summary-article-header)))
 162            (from (mail-header-from header))
 163            (message-id (org-remove-angle-brackets (mail-header-id header)))
 164            (date (org-trim (mail-header-date header)))
 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       (cl-case  (car (gnus-find-method-for-group gnus-newsgroup-name))
 169         (nnvirtual
 170          (setq group (car (nnvirtual-map-article
 171                            (gnus-summary-article-number)))))
 172         (nnir
 173          (setq group (nnir-article-group (gnus-summary-article-number)))))
 174       ;; Remove text properties of subject string to avoid Emacs bug
 175       ;; #3506
 176       (set-text-properties 0 (length subject) nil subject)
 177
 178       ;; Fetching an article is an expensive operation; newsgroup and
 179       ;; x-no-archive are only needed for web links.
 180       (when (org-xor current-prefix-arg org-gnus-prefer-web-links)
 181         ;; Make sure the original article buffer is up-to-date
 182         (save-window-excursion (gnus-summary-select-article))
 183         (setq to (or to (gnus-fetch-original-field "To"))
 184               newsgroups (gnus-fetch-original-field "Newsgroups")
 185               x-no-archive (gnus-fetch-original-field "x-no-archive")))
 186       (org-store-link-props :type "gnus" :from from :date date :subject subject
 187                             :message-id message-id :group group :to to)
 188       (setq desc (org-email-link-description)
 189             link (org-gnus-article-link
 190                   group newsgroups message-id x-no-archive))
 191       (org-add-link-props :link link :description desc)
 192       link))
 193    ((eq major-mode 'message-mode)
 194     (setq org-store-link-plist nil)  ; reset
 195     (save-excursion
 196       (save-restriction
 197         (message-narrow-to-headers)
 198         (and (not (message-fetch-field "Message-ID"))
 199              (message-generate-headers '(Message-ID)))
 200         (goto-char (point-min))
 201         (re-search-forward "^Message-ID: *.*$" nil t)
 202         (put-text-property (match-beginning 0) (match-end 0) 'message-deletable nil)
 203         (let ((gcc (car (last
 204                          (message-unquote-tokens
 205                           (message-tokenize-header (mail-fetch-field "gcc" nil t) " ,")))))
 206               (id (org-remove-angle-brackets (mail-fetch-field "Message-ID")))
 207               (to (mail-fetch-field "To"))
 208               (from (mail-fetch-field "From"))
 209               (subject (mail-fetch-field "Subject"))
 210               desc link
 211               newsgroup xarchive)       ; those are always nil for gcc
 212           (and (not gcc)
 213                (error "Can not create link: No Gcc header found"))
 214           (org-store-link-props :type "gnus" :from from :subject subject
 215                                 :message-id id :group gcc :to to)
 216           (setq desc (org-email-link-description)
 217                 link (org-gnus-article-link
 218                       gcc newsgroup id xarchive))
 219           (org-add-link-props :link link :description desc)
 220           link))))))
 221
 222 (defun org-gnus-open-nntp (path)
 223   "Follow the nntp: link specified by PATH."
 224   (let* ((spec (split-string path "/"))
 225          (server (split-string (nth 2 spec) "@"))
 226          (group (nth 3 spec))
 227          (article (nth 4 spec)))
 228     (org-gnus-follow-link
 229      (format "nntp+%s:%s" (or (cdr server) (car server)) group)
 230      article)))
 231
 232 (defun org-gnus-open (path)
 233   "Follow the Gnus message or folder link specified by PATH."
 234   (let (group article)
 235     (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path))
 236         (error "Error in Gnus link"))
 237     (setq group (match-string 1 path)
 238           article (match-string 3 path))
 239     (when group
 240       (setq group (org-no-properties group)))
 241     (when article
 242       (setq article (org-no-properties article)))
 243     (org-gnus-follow-link group article)))
 244
 245 (defun org-gnus-follow-link (&optional group article)
 246   "Follow a Gnus link to GROUP and ARTICLE."
 247   (require 'gnus)
 248   (funcall (cdr (assq 'gnus org-link-frame-setup)))
 249   (if gnus-other-frame-object (select-frame gnus-other-frame-object))
 250   (setq group (org-no-properties group))
 251   (setq article (org-no-properties article))
 252   (cond ((and group article)
 253          (gnus-activate-group group)
 254          (condition-case nil
 255              (let* ((method (gnus-find-method-for-group group))
 256                     (backend (car method))
 257                     (server (cadr method)))
 258                (cond
 259                 ((eq backend 'nndoc)
 260                  (if (gnus-group-read-group t nil group)
 261                      (gnus-summary-goto-article article nil t)
 262                    (message "Couldn't follow gnus link.  %s"
 263                             "The summary couldn't be opened.")))
 264                 (t
 265                  (let ((articles 1)
 266                        group-opened)
 267                    (when (and (eq backend 'nnimap)
 268                               org-gnus-nnimap-query-article-no-from-file)
 269                      (setq article
 270                            (or (org-gnus-nnimap-cached-article-number
 271                                 (nth 1 (split-string group ":"))
 272                                 server (concat "<" article ">")) article)))
 273                    (while (and (not group-opened)
 274                                ;; stop on integer overflows
 275                                (> articles 0))
 276                      (setq group-opened (gnus-group-read-group
 277                                          articles t group)
 278                            articles (if (< articles 16)
 279                                         (1+ articles)
 280                                       (* articles 2))))
 281                    (if group-opened
 282                        (gnus-summary-goto-article article nil t)
 283                      (message "Couldn't follow gnus link.  %s"
 284                               "The summary couldn't be opened."))))))
 285            (quit (message "Couldn't follow gnus link.  %s"
 286                           "The linked group is empty."))))
 287         (group (gnus-group-jump-to-group group))))
 288
 289 (defun org-gnus-no-new-news ()
 290   "Like `\\[gnus]' but doesn't check for new news."
 291   (if (not (gnus-alive-p)) (if org-gnus-no-server (gnus-no-server) (gnus))))
 292
 293 (provide 'org-gnus)
 294
 295
 296 ;;; org-gnus.el ends here