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