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-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 (declare-function message-fetch-field "message" (header &optional not-all))
  40 (declare-function message-narrow-to-head-1 "message" nil)
  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 (org-defvaralias 'org-usenet-links-prefer-google 'org-gnus-prefer-web-links)
  46
  47 (defcustom org-gnus-prefer-web-links nil
  48   "If non-nil, `org-store-link' creates web links to Google groups or Gmane.
  49 When nil, Gnus will be used for such links.
  50 Using a prefix arg to the command \\[org-store-link] (`org-store-link')
  51 negates this setting for the duration of the command."
  52   :group 'org-link-store
  53   :type 'boolean)
  54
  55 (defcustom org-gnus-nnimap-query-article-no-from-file nil
  56   "If non-nil, `org-gnus-follow-link' will try to translate
  57 Message-Ids to article numbers by querying the .overview file.
  58 Normally, this translation is done by querying the IMAP server,
  59 which is usually very fast.  Unfortunately, some (maybe badly
  60 configured) IMAP servers don't support this operation quickly.
  61 So if following a link to a Gnus article takes ages, try setting
  62 this variable to t."
  63   :group 'org-link-store
  64   :version "24.1"
  65   :type 'boolean)
  66
  67 (defcustom org-gnus-no-server nil
  68   "Should Gnus be started using `gnus-no-server'?"
  69   :group 'org-gnus
  70   :version "24.4"
  71   :package-version '(Org . "8.0")
  72   :type 'boolean)
  73
  74 ;; Install the link type
  75 (org-add-link-type "gnus" 'org-gnus-open)
  76 (add-hook 'org-store-link-functions 'org-gnus-store-link)
  77
  78 ;; Implementation
  79
  80 ;; FIXME: nnimap-group-overview-filename was removed from Gnus in
  81 ;; September 2010.  Perhaps remove this function?
  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 (nnimap-group-overview-filename group server)))
  88       (when (file-exists-p nov)
  89         (mm-insert-file-contents nov)
  90         (set-buffer-modified-p nil)
  91         (goto-char (point-min))
  92         (catch 'found
  93           (while (search-forward message-id nil t)
  94             (let ((hdr (split-string (thing-at-point 'line) "\t")))
  95               (if (string= (nth 4 hdr) message-id)
  96                   (throw 'found (nth 0 hdr))))))))))
  97
  98 (defun org-gnus-group-link (group)
  99   "Create a link to the Gnus group GROUP.
 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 group 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   (let ((unprefixed-group (replace-regexp-in-string "^[^:]+:" "" group)))
 107     (if (and (string-match "^nntp" group) ;; Only for nntp groups
 108              (org-xor current-prefix-arg
 109                       org-gnus-prefer-web-links))
 110         (concat (if (string-match "gmane" unprefixed-group)
 111                     "http://news.gmane.org/"
 112                   "http://groups.google.com/group/")
 113                 unprefixed-group)
 114       (concat "gnus:" group))))
 115
 116 (defun org-gnus-article-link (group newsgroups message-id x-no-archive)
 117   "Create a link to a Gnus article.
 118 The article is specified by its MESSAGE-ID.  Additional
 119 parameters are the Gnus GROUP, the NEWSGROUPS the article was
 120 posted to and the X-NO-ARCHIVE header value of that article.
 121
 122 If GROUP is a newsgroup and `org-gnus-prefer-web-links' is
 123 non-nil, create a link to groups.google.com or gmane.org.
 124 Otherwise create a link to the article inside Gnus.
 125
 126 If `org-store-link' was called with a prefix arg the meaning of
 127 `org-gnus-prefer-web-links' is reversed."
 128   (if (and (org-xor current-prefix-arg org-gnus-prefer-web-links)
 129            newsgroups     ;; Make web links only for nntp groups
 130            (not x-no-archive)) ;; and if X-No-Archive isn't set.
 131       (format (if (string-match "gmane\\." newsgroups)
 132                   "http://mid.gmane.org/%s"
 133                 "http://groups.google.com/groups/search?as_umsgid=%s")
 134               (org-fixup-message-id-for-http message-id))
 135     (concat "gnus:" group "#" message-id)))
 136
 137 (defun org-gnus-store-link ()
 138   "Store a link to a Gnus folder or message."
 139   (cond
 140    ((eq major-mode 'gnus-group-mode)
 141     (let* ((group (cond ((fboundp 'gnus-group-group-name) ; depending on Gnus
 142                          (gnus-group-group-name))         ; version
 143                         ((fboundp 'gnus-group-name)
 144                          (gnus-group-name))
 145                         (t "???")))
 146            desc link)
 147       (when group
 148         (org-store-link-props :type "gnus" :group group)
 149         (setq desc (org-gnus-group-link group)
 150               link desc)
 151         (org-add-link-props :link link :description desc)
 152         link)))
 153
 154    ((memq major-mode '(gnus-summary-mode gnus-article-mode))
 155     (let* ((group gnus-newsgroup-name)
 156            (header (with-current-buffer gnus-summary-buffer
 157                      (gnus-summary-article-header)))
 158            (from (mail-header-from header))
 159            (message-id (org-remove-angle-brackets (mail-header-id header)))
 160            (date (org-trim (mail-header-date header)))
 161            (date-ts (and date
 162                          (ignore-errors
 163                            (format-time-string
 164                             (org-time-stamp-format t)
 165                             (date-to-time date)))))
 166            (date-ts-ia (and date
 167                             (ignore-errors
 168                               (format-time-string
 169                                (org-time-stamp-format t t)
 170                                (date-to-time date)))))
 171            (subject (copy-sequence (mail-header-subject header)))
 172            (to (cdr (assq 'To (mail-header-extra header))))
 173            newsgroups x-no-archive desc link)
 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 :subject subject
 187                             :message-id message-id :group group :to to)
 188       (when date
 189         (org-add-link-props :date date :date-timestamp date-ts
 190                             :date-timestamp-inactive date-ts-ia))
 191       (setq desc (org-email-link-description)
 192             link (org-gnus-article-link
 193                   group newsgroups message-id x-no-archive))
 194       (org-add-link-props :link link :description desc)
 195       link))
 196    ((eq major-mode 'message-mode)
 197     (setq org-store-link-plist nil)  ; reset
 198     (save-excursion
 199       (save-restriction
 200         (message-narrow-to-headers)
 201         (and (not (message-fetch-field "Message-ID"))
 202              (message-generate-headers '(Message-ID)))
 203         (goto-char (point-min))
 204         (re-search-forward "^Message-ID: *.*$" nil t)
 205         (put-text-property (match-beginning 0) (match-end 0) 'message-deletable nil)
 206         (let ((gcc (car (last
 207                          (message-unquote-tokens
 208                           (message-tokenize-header (mail-fetch-field "gcc" nil t) " ,")))))
 209               (id (org-remove-angle-brackets (mail-fetch-field "Message-ID")))
 210               (to (mail-fetch-field "To"))
 211               (from (mail-fetch-field "From"))
 212               (subject (mail-fetch-field "Subject"))
 213               desc link
 214               newsgroup xarchive)       ; those are always nil for gcc
 215           (and (not gcc)
 216                (error "Can not create link: No Gcc header found"))
 217           (org-store-link-props :type "gnus" :from from :subject subject
 218                                 :message-id id :group gcc :to to)
 219           (setq desc (org-email-link-description)
 220                 link (org-gnus-article-link
 221                       gcc newsgroup id xarchive))
 222           (org-add-link-props :link link :description desc)
 223           link))))))
 224
 225 (defun org-gnus-open-nntp (path)
 226   "Follow the nntp: link specified by PATH."
 227   (let* ((spec (split-string path "/"))
 228          (server (split-string (nth 2 spec) "@"))
 229          (group (nth 3 spec))
 230          (article (nth 4 spec)))
 231     (org-gnus-follow-link
 232      (format "nntp+%s:%s" (or (cdr server) (car server)) group)
 233      article)))
 234
 235 (defun org-gnus-open (path)
 236   "Follow the Gnus message or folder link specified by PATH."
 237   (let (group article)
 238     (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path))
 239         (error "Error in Gnus link"))
 240     (setq group (match-string 1 path)
 241           article (match-string 3 path))
 242     (when group
 243       (setq group (org-no-properties group)))
 244     (when article
 245       (setq article (org-no-properties article)))
 246     (org-gnus-follow-link group article)))
 247
 248 (defun org-gnus-follow-link (&optional group article)
 249   "Follow a Gnus link to GROUP and ARTICLE."
 250   (require 'gnus)
 251   (funcall (cdr (assq 'gnus org-link-frame-setup)))
 252   (if gnus-other-frame-object (select-frame gnus-other-frame-object))
 253   (when group
 254     (setq group (org-no-properties group)))
 255   (when article
 256     (setq article (org-no-properties article)))
 257   (cond ((and group article)
 258          (gnus-activate-group group)
 259          (condition-case nil
 260              (let* ((method (gnus-find-method-for-group group))
 261                     (backend (car method))
 262                     (server (cadr method)))
 263                (cond
 264                 ((eq backend 'nndoc)
 265                  (if (gnus-group-read-group t nil group)
 266                      (gnus-summary-goto-article article nil t)
 267                    (message "Couldn't follow gnus link.  %s"
 268                             "The summary couldn't be opened.")))
 269                 (t
 270                  (let ((articles 1)
 271                        group-opened)
 272                    (when (and (eq backend 'nnimap)
 273                               org-gnus-nnimap-query-article-no-from-file)
 274                      (setq article
 275                            (or (org-gnus-nnimap-cached-article-number
 276                                 (nth 1 (split-string group ":"))
 277                                 server (concat "<" article ">")) article)))
 278                    (while (and (not group-opened)
 279                                ;; stop on integer overflows
 280                                (> articles 0))
 281                      (setq group-opened (gnus-group-read-group
 282                                          articles t group)
 283                            articles (if (< articles 16)
 284                                         (1+ articles)
 285                                       (* articles 2))))
 286                    (if group-opened
 287                        (gnus-summary-goto-article article nil t)
 288                      (message "Couldn't follow gnus link.  %s"
 289                               "The summary couldn't be opened."))))))
 290            (quit (message "Couldn't follow gnus link.  %s"
 291                           "The linked group is empty."))))
 292         (group (gnus-group-jump-to-group group))))
 293
 294 (defun org-gnus-no-new-news ()
 295   "Like `\\[gnus]' but doesn't check for new news."
 296   (if (not (gnus-alive-p)) (if org-gnus-no-server (gnus-no-server) (gnus))))
 297
 298 (provide 'org-gnus)
 299
 300
 301 ;;; org-gnus.el ends here