1 ;;; org-gnus.el --- Support for Links to Gnus Groups and Messages -*- lexical-binding: t; -*-
3 ;; Copyright (C) 2004-2017 Free Software Foundation, Inc.
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
10 ;; This file is part of GNU Emacs.
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.
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.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
24 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28 ;; This file implements links to Gnus groups and messages from within Org.
29 ;; Org mode loads this module by default - if this is not what you want,
30 ;; configure the variable `org-modules'.
41 ;;; Declare external functions and variables
43 (declare-function gnus-activate-group
"gnus-start" (group &optional scan dont-check method dont-sub-check
))
44 (declare-function gnus-find-method-for-group
"gnus" (group &optional info
))
45 (declare-function gnus-group-group-name
"gnus-group")
46 (declare-function gnus-group-jump-to-group
"gnus-group" (group &optional prompt
))
47 (declare-function gnus-group-read-group
"gnus-group" (&optional all no-article group select-articles
))
48 (declare-function message-fetch-field
"message" (header &optional not-all
))
49 (declare-function message-generate-headers
"message" (headers))
50 (declare-function message-narrow-to-headers
"message")
51 (declare-function message-tokenize-header
"message" (header &optional separator
))
52 (declare-function message-unquote-tokens
"message" (elems))
53 (declare-function nnvirtual-map-article
"nnvirtual" (article))
55 (defvar gnus-newsgroup-name
)
56 (defvar gnus-summary-buffer
)
57 (defvar gnus-other-frame-object
)
60 ;;; Customization variables
62 (defcustom org-gnus-prefer-web-links nil
63 "If non-nil, `org-store-link' creates web links to Google groups or Gmane.
64 \\<org-mode-map>When nil, Gnus will be used for such links.
65 Using a prefix argument to the command `\\[org-store-link]' (`org-store-link')
66 negates this setting for the duration of the command."
67 :group
'org-link-store
70 (defcustom org-gnus-no-server nil
71 "Should Gnus be started using `gnus-no-server'?"
74 :package-version
'(Org .
"8.0")
78 ;;; Install the link type
80 (org-link-set-parameters "gnus"
81 :follow
#'org-gnus-open
82 :store
#'org-gnus-store-link
)
86 (defun org-gnus-group-link (group)
87 "Create a link to the Gnus group GROUP.
88 If GROUP is a newsgroup and `org-gnus-prefer-web-links' is
89 non-nil, create a link to groups.google.com or gmane.org.
90 Otherwise create a link to the group inside Gnus.
92 If `org-store-link' was called with a prefix arg the meaning of
93 `org-gnus-prefer-web-links' is reversed."
94 (let ((unprefixed-group (replace-regexp-in-string "^[^:]+:" "" group
)))
95 (if (and (string-prefix-p "nntp" group
) ;; Only for nntp groups
96 (org-xor current-prefix-arg
97 org-gnus-prefer-web-links
))
98 (concat (if (string-match "gmane" unprefixed-group
)
99 "http://news.gmane.org/"
100 "http://groups.google.com/group/")
102 (concat "gnus:" group
))))
104 (defun org-gnus-article-link (group newsgroups message-id x-no-archive
)
105 "Create a link to a Gnus article.
106 The article is specified by its MESSAGE-ID. Additional
107 parameters are the Gnus GROUP, the NEWSGROUPS the article was
108 posted to and the X-NO-ARCHIVE header value of that article.
110 If GROUP is a newsgroup and `org-gnus-prefer-web-links' is
111 non-nil, create a link to groups.google.com or gmane.org.
112 Otherwise create a link to the article inside Gnus.
114 If `org-store-link' was called with a prefix arg the meaning of
115 `org-gnus-prefer-web-links' is reversed."
116 (if (and (org-xor current-prefix-arg org-gnus-prefer-web-links
)
117 newsgroups
;; Make web links only for nntp groups
118 (not x-no-archive
)) ;; and if X-No-Archive isn't set.
119 (format (if (string-match "gmane\\." newsgroups
)
120 "http://mid.gmane.org/%s"
121 "http://groups.google.com/groups/search?as_umsgid=%s")
122 (org-fixup-message-id-for-http message-id
))
123 (concat "gnus:" group
"#" message-id
)))
125 (defun org-gnus-store-link ()
126 "Store a link to a Gnus folder or message."
129 (let ((group (gnus-group-group-name)))
131 (org-store-link-props :type
"gnus" :group group
)
132 (let ((description (org-gnus-group-link group
)))
133 (org-add-link-props :link description
:description description
)
135 ((or `gnus-summary-mode
`gnus-article-mode
)
137 (pcase (gnus-find-method-for-group gnus-newsgroup-name
)
140 (car (nnvirtual-map-article (gnus-summary-article-number)))))
143 (nnir-article-group (gnus-summary-article-number))))
144 (_ gnus-newsgroup-name
)))
145 (header (with-current-buffer gnus-summary-buffer
146 (gnus-summary-article-header)))
147 (from (mail-header-from header
))
148 (message-id (org-unbracket-string "<" ">" (mail-header-id header
)))
149 (date (org-trim (mail-header-date header
)))
150 ;; Remove text properties of subject string to avoid Emacs
152 (subject (org-no-properties
153 (copy-sequence (mail-header-subject header
))))
154 (to (cdr (assq 'To
(mail-header-extra header
))))
155 newsgroups x-no-archive
)
156 ;; Fetching an article is an expensive operation; newsgroup and
157 ;; x-no-archive are only needed for web links.
158 (when (org-xor current-prefix-arg org-gnus-prefer-web-links
)
159 ;; Make sure the original article buffer is up-to-date.
160 (save-window-excursion (gnus-summary-select-article))
161 (setq to
(or to
(gnus-fetch-original-field "To")))
162 (setq newsgroups
(gnus-fetch-original-field "Newsgroups"))
163 (setq x-no-archive
(gnus-fetch-original-field "x-no-archive")))
164 (org-store-link-props :type
"gnus" :from from
:date date
:subject subject
165 :message-id message-id
:group group
:to to
)
166 (let ((link (org-gnus-article-link
167 group newsgroups message-id x-no-archive
))
168 (description (org-email-link-description)))
169 (org-add-link-props :link link
:description description
)
172 (setq org-store-link-plist nil
) ;reset
175 (message-narrow-to-headers)
176 (unless (message-fetch-field "Message-ID")
177 (message-generate-headers '(Message-ID)))
178 (goto-char (point-min))
179 (re-search-forward "^Message-ID:" nil t
)
180 (put-text-property (line-beginning-position) (line-end-position)
181 'message-deletable nil
)
182 (let ((gcc (org-last (message-unquote-tokens
183 (message-tokenize-header
184 (mail-fetch-field "gcc" nil t
) " ,"))))
185 (id (org-unbracket-string "<" ">"
186 (mail-fetch-field "Message-ID")))
187 (to (mail-fetch-field "To"))
188 (from (mail-fetch-field "From"))
189 (subject (mail-fetch-field "Subject"))
190 newsgroup xarchive
) ;those are always nil for gcc
191 (unless gcc
(error "Can not create link: No Gcc header found"))
192 (org-store-link-props :type
"gnus" :from from
:subject subject
193 :message-id id
:group gcc
:to to
)
194 (let ((link (org-gnus-article-link gcc newsgroup id xarchive
))
195 (description (org-email-link-description)))
196 (org-add-link-props :link link
:description description
)
199 (defun org-gnus-open-nntp (path)
200 "Follow the nntp: link specified by PATH."
201 (let* ((spec (split-string path
"/"))
202 (server (split-string (nth 2 spec
) "@"))
204 (article (nth 4 spec
)))
205 (org-gnus-follow-link
206 (format "nntp+%s:%s" (or (cdr server
) (car server
)) group
)
209 (defun org-gnus-open (path)
210 "Follow the Gnus message or folder link specified by PATH."
211 (unless (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path
)
212 (error "Error in Gnus link %S" path
))
213 (let ((group (match-string-no-properties 1 path
))
214 (article (match-string-no-properties 3 path
)))
215 (org-gnus-follow-link group article
)))
217 (defun org-gnus-follow-link (&optional group article
)
218 "Follow a Gnus link to GROUP and ARTICLE."
220 (funcall (cdr (assq 'gnus org-link-frame-setup
)))
221 (when gnus-other-frame-object
(select-frame gnus-other-frame-object
))
222 (let ((group (org-no-properties group
))
223 (article (org-no-properties article
)))
226 (gnus-activate-group group
)
228 (let ((msg "Couldn't follow Gnus link. Summary couldn't be opened."))
229 (pcase (gnus-find-method-for-group group
)
231 (if (gnus-group-read-group t nil group
)
232 (gnus-summary-goto-article article nil t
)
237 (while (and (not group-opened
)
238 ;; Stop on integer overflows.
240 (setq group-opened
(gnus-group-read-group articles t group
))
241 (setq articles
(if (< articles
16)
245 (gnus-summary-goto-article article nil t
)
248 (message "Couldn't follow Gnus link. The linked group is empty."))))
249 (group (gnus-group-jump-to-group group
)))))
251 (defun org-gnus-no-new-news ()
252 "Like `\\[gnus]' but doesn't check for new news."
253 (cond ((gnus-alive-p) nil
)
254 (org-gnus-no-server (gnus-no-server))
260 ;;; org-gnus.el ends here