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