1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
|
;;; ol-gnus.el --- Links to Gnus Groups and Messages -*- lexical-binding: t; -*-
;; Copyright (C) 2004-2025 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
;; Tassilo Horn <tassilo at member dot fsf dot org>
;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;;
;; This file is part of GNU Emacs.
;;
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;; This file implements links to Gnus groups and messages from within Org.
;; Org mode loads this module by default - if this is not what you want,
;; configure the variable `org-modules'.
;;; Code:
(require 'org-macs)
(org-assert-version)
(require 'gnus-sum)
(require 'gnus-util)
(require 'nnheader)
(or (require 'nnselect nil t) ; Emacs >= 28
(require 'nnir nil t)) ; Emacs < 28
(require 'ol)
;;; Declare external functions and variables
(declare-function gnus-activate-group "gnus-start" (group &optional scan dont-check method dont-sub-check))
(declare-function gnus-find-method-for-group "gnus" (group &optional info))
(declare-function gnus-article-show-summary "gnus-art" ())
(declare-function gnus-group-group-name "gnus-group")
(declare-function gnus-group-jump-to-group "gnus-group" (group &optional prompt))
(declare-function gnus-group-read-group "gnus-group" (&optional all no-article group select-articles))
(declare-function message-fetch-field "message" (header &optional not-all))
(declare-function message-generate-headers "message" (headers))
(declare-function message-narrow-to-headers "message")
(declare-function message-tokenize-header "message" (header &optional separator))
(declare-function message-unquote-tokens "message" (elems))
(declare-function nnvirtual-map-article "nnvirtual" (article))
(defvar gnus-newsgroup-name)
(defvar gnus-summary-buffer)
(defvar gnus-other-frame-object)
;;; Customization variables
(defcustom org-gnus-prefer-web-links nil
"If non-nil, `org-store-link' creates web links to Google groups.
\\<org-mode-map>When nil, Gnus will be used for such links.
Using a prefix argument to the command `\\[org-store-link]' (`org-store-link')
negates this setting for the duration of the command."
:group 'org-link-store
:type 'boolean)
(defcustom org-gnus-no-server nil
"Should Gnus be started using `gnus-no-server'?"
:group 'org-link-follow
:version "24.4"
:package-version '(Org . "8.0")
:type 'boolean)
;;; Install the link type
(org-link-set-parameters "gnus"
:follow #'org-gnus-open
:store #'org-gnus-store-link)
;;; Implementation
(defun org-gnus-group-link (group)
"Create a link to the Gnus group GROUP.
If GROUP is a newsgroup and `org-gnus-prefer-web-links' is
non-nil, create a link to groups.google.com. Otherwise create a
link to the group inside Gnus.
If `org-store-link' was called with a prefix arg the meaning of
`org-gnus-prefer-web-links' is reversed."
(let ((unprefixed-group (replace-regexp-in-string "^[^:]+:" "" group)))
(if (and (string-prefix-p "nntp" group) ;; Only for nntp groups
(org-xor current-prefix-arg
org-gnus-prefer-web-links))
(concat "https://groups.google.com/group/" unprefixed-group)
(concat "gnus:" group))))
(defun org-gnus-article-link (group newsgroups message-id x-no-archive)
"Create a link to a Gnus article.
The article is specified by its MESSAGE-ID. Additional
parameters are the Gnus GROUP, the NEWSGROUPS the article was
posted to and the X-NO-ARCHIVE header value of that article.
If GROUP is a newsgroup and `org-gnus-prefer-web-links' is
non-nil, create a link to groups.google.com.
Otherwise create a link to the article inside Gnus.
If `org-store-link' was called with a prefix arg the meaning of
`org-gnus-prefer-web-links' is reversed."
(if (and (org-xor current-prefix-arg org-gnus-prefer-web-links)
newsgroups ;make web links only for nntp groups
(not x-no-archive)) ;and if X-No-Archive isn't set
(format "https://groups.google.com/groups/search?as_umsgid=%s"
(url-encode-url message-id))
(concat "gnus:" group "#" message-id)))
(defun org-gnus-store-link (&optional _interactive?)
"Store a link to a Gnus folder or message."
(pcase major-mode
(`gnus-group-mode
(let ((group (gnus-group-group-name)))
(when group
(org-link-store-props :type "gnus" :group group)
(let ((description (org-gnus-group-link group)))
(org-link-add-props :link description :description description)
description))))
((or `gnus-summary-mode `gnus-article-mode)
(let* ((group
(pcase (gnus-find-method-for-group gnus-newsgroup-name)
(`(nnvirtual . ,_)
(with-current-buffer gnus-summary-buffer
(save-excursion
(car (nnvirtual-map-article (gnus-summary-article-number))))))
(`(,(or `nnselect `nnir) . ,_) ; nnir is for Emacs < 28.
(with-current-buffer gnus-summary-buffer
(save-excursion
(cond
((fboundp 'nnselect-article-group)
(nnselect-article-group (gnus-summary-article-number)))
((fboundp 'nnir-article-group)
(nnir-article-group (gnus-summary-article-number)))
(t
(error "No article-group variant bound"))))))
(_ gnus-newsgroup-name)))
(header (with-current-buffer gnus-summary-buffer
(save-excursion
(gnus-summary-article-header))))
(from (mail-header-from header))
(message-id (org-unbracket-string "<" ">" (mail-header-id header)))
(date (org-trim (mail-header-date header)))
;; Remove text properties of subject string to avoid Emacs
;; bug #3506.
(subject (org-no-properties
(copy-sequence (mail-header-subject header))))
(to (cdr (assq 'To (mail-header-extra header))))
newsgroups x-no-archive)
;; Fetching an article is an expensive operation; newsgroup and
;; x-no-archive are only needed for web links.
(when (org-xor current-prefix-arg org-gnus-prefer-web-links)
;; Make sure the original article buffer is up-to-date.
(save-window-excursion (gnus-summary-select-article))
(setq to (or to (gnus-fetch-original-field "To")))
(setq newsgroups (gnus-fetch-original-field "Newsgroups"))
(setq x-no-archive (gnus-fetch-original-field "x-no-archive")))
(org-link-store-props :type "gnus" :from from :date date :subject subject
:message-id message-id :group group :to to)
(let ((link (org-gnus-article-link
group newsgroups message-id x-no-archive))
(description (org-link-email-description)))
(org-link-add-props :link link :description description)
link)))
(`message-mode
(setq org-store-link-plist nil) ;reset
(save-excursion
(save-restriction
(message-narrow-to-headers)
(unless (message-fetch-field "Message-ID")
(message-generate-headers '(Message-ID)))
(goto-char (point-min))
(re-search-forward "^Message-ID:" nil t)
(put-text-property (line-beginning-position) (line-end-position)
'message-deletable nil)
(let ((gcc (org-last (message-unquote-tokens
(message-tokenize-header
(mail-fetch-field "gcc" nil t) " ,"))))
(id (org-unbracket-string "<" ">"
(mail-fetch-field "Message-ID")))
(to (mail-fetch-field "To"))
(from (mail-fetch-field "From"))
(subject (mail-fetch-field "Subject"))
) ;; newsgroup xarchive ;those are always nil for gcc
(unless gcc (error "Can not create link: No Gcc header found"))
(org-link-store-props :type "gnus" :from from :subject subject
:message-id id :group gcc :to to)
(let ((link (org-gnus-article-link gcc nil id nil)) ;;newsgroup xarchive
(description (org-link-email-description)))
(org-link-add-props :link link :description description)
link)))))))
(defun org-gnus-open-nntp (path)
"Follow the nntp: link specified by PATH."
(let* ((spec (split-string path "/"))
(server (split-string (nth 2 spec) "@"))
(group (nth 3 spec))
(article (nth 4 spec)))
(org-gnus-follow-link
(format "nntp+%s:%s" (or (cdr server) (car server)) group)
article)))
(defun org-gnus-open (path _)
"Follow the Gnus message or folder link specified by PATH."
(unless (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)
(error "Error in Gnus link %S" path))
(let ((group (match-string-no-properties 1 path))
(article (match-string-no-properties 3 path)))
(org-gnus-follow-link group article)))
(defun org-gnus-follow-link (&optional group article)
"Follow a Gnus link to GROUP and ARTICLE."
(require 'gnus)
(funcall (cdr (assq 'gnus org-link-frame-setup)))
(when gnus-other-frame-object (select-frame gnus-other-frame-object))
(let ((group (org-no-properties group))
(article (org-no-properties article)))
(cond
((and group article)
(gnus-activate-group group)
(condition-case nil
(let ((msg "Couldn't follow Gnus link. Summary couldn't be opened."))
(pcase (gnus-find-method-for-group group)
(`(nndoc . ,_)
(if (gnus-group-read-group t nil group)
(gnus-summary-goto-article article nil t)
(message msg)))
(_
(let ((articles 1)
group-opened)
(while (and (not group-opened)
;; Stop on integer overflows. Note: We
;; can drop this once we require at least
;; Emacs 27, which supports bignums.
(> articles 0))
(setq group-opened (gnus-group-read-group articles t group))
(setq articles (if (< articles 16)
(1+ articles)
(* articles 2))))
(if group-opened
(gnus-summary-goto-article article nil t)
(message msg))))))
(quit
(message "Couldn't follow Gnus link. The linked group is empty."))))
(group (gnus-group-jump-to-group group)))))
(defun org-gnus-no-new-news ()
"Like `\\[gnus]' but doesn't check for new news."
(cond ((gnus-alive-p) nil)
(org-gnus-no-server (gnus-no-server))
(t (gnus))))
(provide 'ol-gnus)
;;; ol-gnus.el ends here
|
