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