1 ;;; org-gnus.el --- Support for Links to Gnus Groups and Messages -*- lexical-binding: t; -*-
3 ;; Copyright (C) 2004-2018 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: https://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-article-show-summary
"gnus-art" ())
46 (declare-function gnus-group-group-name
"gnus-group")
47 (declare-function gnus-group-jump-to-group
"gnus-group" (group &optional prompt
))
48 (declare-function gnus-group-read-group
"gnus-group" (&optional all no-article group select-articles
))
49 (declare-function message-fetch-field
"message" (header &optional not-all
))
50 (declare-function message-generate-headers
"message" (headers))
51 (declare-function message-narrow-to-headers
"message")
52 (declare-function message-tokenize-header
"message" (header &optional separator
))
53 (declare-function message-unquote-tokens
"message" (elems))
54 (declare-function nnvirtual-map-article
"nnvirtual" (article))
56 (defvar gnus-newsgroup-name
)
57 (defvar gnus-summary-buffer
)
58 (defvar gnus-other-frame-object
)
61 ;;; Customization variables
63 (defcustom org-gnus-prefer-web-links nil
64 "If non-nil, `org-store-link' creates web links to Google groups or Gmane.
65 \\<org-mode-map>When nil, Gnus will be used for such links.
66 Using a prefix argument to the command `\\[org-store-link]' (`org-store-link')
67 negates this setting for the duration of the command."
68 :group
'org-link-store
71 (defcustom org-gnus-no-server nil
72 "Should Gnus be started using `gnus-no-server'?"
75 :package-version
'(Org .
"8.0")
79 ;;; Install the link type
81 (org-link-set-parameters "gnus"
82 :follow
#'org-gnus-open
83 :store
#'org-gnus-store-link
)
87 (defun org-gnus-group-link (group)
88 "Create a link to the Gnus group GROUP.
89 If GROUP is a newsgroup and `org-gnus-prefer-web-links' is
90 non-nil, create a link to groups.google.com or gmane.org.
91 Otherwise create a link to the group inside Gnus.
93 If `org-store-link' was called with a prefix arg the meaning of
94 `org-gnus-prefer-web-links' is reversed."
95 (let ((unprefixed-group (replace-regexp-in-string "^[^:]+:" "" group
)))
96 (if (and (string-prefix-p "nntp" group
) ;; Only for nntp groups
97 (org-xor current-prefix-arg
98 org-gnus-prefer-web-links
))
99 (concat (if (string-match "gmane" unprefixed-group
)
100 "http://news.gmane.org/"
101 "http://groups.google.com/group/")
103 (concat "gnus:" group
))))
105 (defun org-gnus-article-link (group newsgroups message-id x-no-archive
)
106 "Create a link to a Gnus article.
107 The article is specified by its MESSAGE-ID. Additional
108 parameters are the Gnus GROUP, the NEWSGROUPS the article was
109 posted to and the X-NO-ARCHIVE header value of that article.
111 If GROUP is a newsgroup and `org-gnus-prefer-web-links' is
112 non-nil, create a link to groups.google.com or gmane.org.
113 Otherwise create a link to the article inside Gnus.
115 If `org-store-link' was called with a prefix arg the meaning of
116 `org-gnus-prefer-web-links' is reversed."
117 (if (and (org-xor current-prefix-arg org-gnus-prefer-web-links
)
118 newsgroups
;; Make web links only for nntp groups
119 (not x-no-archive
)) ;; and if X-No-Archive isn't set.
120 (format (if (string-match "gmane\\." newsgroups
)
121 "http://mid.gmane.org/%s"
122 "http://groups.google.com/groups/search?as_umsgid=%s")
123 (org-fixup-message-id-for-http message-id
))
124 (concat "gnus:" group
"#" message-id
)))
126 (defun org-gnus-store-link ()
127 "Store a link to a Gnus folder or message."
130 (let ((group (gnus-group-group-name)))
132 (org-store-link-props :type
"gnus" :group group
)
133 (let ((description (org-gnus-group-link group
)))
134 (org-add-link-props :link description
:description description
)
136 ((or `gnus-summary-mode
`gnus-article-mode
)
138 (pcase (gnus-find-method-for-group gnus-newsgroup-name
)
141 (car (nnvirtual-map-article (gnus-summary-article-number)))))
144 (nnir-article-group (gnus-summary-article-number))))
145 (_ gnus-newsgroup-name
)))
146 (header (if (eq major-mode
'gnus-article-mode
)
147 ;; When in an article, first move to summary
148 ;; buffer, with point on the summary of the
149 ;; current article before extracting headers.
150 (save-window-excursion
152 (gnus-article-show-summary)
153 (gnus-summary-article-header)))
154 (gnus-summary-article-header)))
155 (from (mail-header-from header
))
156 (message-id (org-unbracket-string "<" ">" (mail-header-id header
)))
157 (date (org-trim (mail-header-date header
)))
158 ;; Remove text properties of subject string to avoid Emacs
160 (subject (org-no-properties
161 (copy-sequence (mail-header-subject header
))))
162 (to (cdr (assq 'To
(mail-header-extra header
))))
163 newsgroups x-no-archive
)
164 ;; Fetching an article is an expensive operation; newsgroup and
165 ;; x-no-archive are only needed for web links.
166 (when (org-xor current-prefix-arg org-gnus-prefer-web-links
)
167 ;; Make sure the original article buffer is up-to-date.
168 (save-window-excursion (gnus-summary-select-article))
169 (setq to
(or to
(gnus-fetch-original-field "To")))
170 (setq newsgroups
(gnus-fetch-original-field "Newsgroups"))
171 (setq x-no-archive
(gnus-fetch-original-field "x-no-archive")))
172 (org-store-link-props :type
"gnus" :from from
:date date
:subject subject
173 :message-id message-id
:group group
:to to
)
174 (let ((link (org-gnus-article-link
175 group newsgroups message-id x-no-archive
))
176 (description (org-email-link-description)))
177 (org-add-link-props :link link
:description description
)
180 (setq org-store-link-plist nil
) ;reset
183 (message-narrow-to-headers)
184 (unless (message-fetch-field "Message-ID")
185 (message-generate-headers '(Message-ID)))
186 (goto-char (point-min))
187 (re-search-forward "^Message-ID:" nil t
)
188 (put-text-property (line-beginning-position) (line-end-position)
189 'message-deletable nil
)
190 (let ((gcc (org-last (message-unquote-tokens
191 (message-tokenize-header
192 (mail-fetch-field "gcc" nil t
) " ,"))))
193 (id (org-unbracket-string "<" ">"
194 (mail-fetch-field "Message-ID")))
195 (to (mail-fetch-field "To"))
196 (from (mail-fetch-field "From"))
197 (subject (mail-fetch-field "Subject"))
198 newsgroup xarchive
) ;those are always nil for gcc
199 (unless gcc
(error "Can not create link: No Gcc header found"))
200 (org-store-link-props :type
"gnus" :from from
:subject subject
201 :message-id id
:group gcc
:to to
)
202 (let ((link (org-gnus-article-link gcc newsgroup id xarchive
))
203 (description (org-email-link-description)))
204 (org-add-link-props :link link
:description description
)
207 (defun org-gnus-open-nntp (path)
208 "Follow the nntp: link specified by PATH."
209 (let* ((spec (split-string path
"/"))
210 (server (split-string (nth 2 spec
) "@"))
212 (article (nth 4 spec
)))
213 (org-gnus-follow-link
214 (format "nntp+%s:%s" (or (cdr server
) (car server
)) group
)
217 (defun org-gnus-open (path)
218 "Follow the Gnus message or folder link specified by PATH."
219 (unless (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path
)
220 (error "Error in Gnus link %S" path
))
221 (let ((group (match-string-no-properties 1 path
))
222 (article (match-string-no-properties 3 path
)))
223 (org-gnus-follow-link group article
)))
225 (defun org-gnus-follow-link (&optional group article
)
226 "Follow a Gnus link to GROUP and ARTICLE."
228 (funcall (cdr (assq 'gnus org-link-frame-setup
)))
229 (when gnus-other-frame-object
(select-frame gnus-other-frame-object
))
230 (let ((group (org-no-properties group
))
231 (article (org-no-properties article
)))
234 (gnus-activate-group group
)
236 (let ((msg "Couldn't follow Gnus link. Summary couldn't be opened."))
237 (pcase (gnus-find-method-for-group group
)
239 (if (gnus-group-read-group t nil group
)
240 (gnus-summary-goto-article article nil t
)
245 (while (and (not group-opened
)
246 ;; Stop on integer overflows.
248 (setq group-opened
(gnus-group-read-group articles t group
))
249 (setq articles
(if (< articles
16)
253 (gnus-summary-goto-article article nil t
)
256 (message "Couldn't follow Gnus link. The linked group is empty."))))
257 (group (gnus-group-jump-to-group group
)))))
259 (defun org-gnus-no-new-news ()
260 "Like `\\[gnus]' but doesn't check for new news."
261 (cond ((gnus-alive-p) nil
)
262 (org-gnus-no-server (gnus-no-server))
268 ;;; org-gnus.el ends here