Commit | Line | Data |
---|---|---|
20908596 CD |
1 | ;;; org-gnus.el --- Support for links to Gnus groups and messages from within Org-mode |
2 | ||
ab422c4d | 3 | ;; Copyright (C) 2004-2013 Free Software Foundation, Inc. |
20908596 CD |
4 | |
5 | ;; Author: Carsten Dominik <carsten at orgmode dot org> | |
ce4fdcb9 | 6 | ;; Tassilo Horn <tassilo at member dot fsf dot org> |
20908596 CD |
7 | ;; Keywords: outlines, hypermedia, calendar, wp |
8 | ;; Homepage: http://orgmode.org | |
20908596 CD |
9 | ;; |
10 | ;; This file is part of GNU Emacs. | |
11 | ;; | |
b1fc2b50 | 12 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
20908596 | 13 | ;; it under the terms of the GNU General Public License as published by |
b1fc2b50 GM |
14 | ;; the Free Software Foundation, either version 3 of the License, or |
15 | ;; (at your option) any later version. | |
20908596 CD |
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 | |
b1fc2b50 | 23 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
20908596 CD |
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) | |
8223b1d2 | 35 | (require 'gnus-util) |
21ee034d | 36 | (eval-when-compile (require 'gnus-sum)) |
20908596 | 37 | |
8d642074 CD |
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) | |
afe98dfa | 41 | (declare-function nnimap-group-overview-filename "nnimap" (group server)) |
8d642074 CD |
42 | ;; The following line suppresses a compiler warning stemming from gnus-sum.el |
43 | (declare-function gnus-summary-last-subject "gnus-sum" nil) | |
20908596 CD |
44 | ;; Customization variables |
45 | ||
ce4fdcb9 | 46 | (when (fboundp 'defvaralias) |
ff4be292 | 47 | (defvaralias 'org-usenet-links-prefer-google 'org-gnus-prefer-web-links)) |
ce4fdcb9 CD |
48 | |
49 | (defcustom org-gnus-prefer-web-links nil | |
86fbb8ca | 50 | "If non-nil, `org-store-link' creates web links to Google groups or Gmane. |
20908596 CD |
51 | When nil, Gnus will be used for such links. |
52 | Using a prefix arg to the command \\[org-store-link] (`org-store-link') | |
53 | negates this setting for the duration of the command." | |
54 | :group 'org-link-store | |
55 | :type 'boolean) | |
56 | ||
afe98dfa CD |
57 | (defcustom org-gnus-nnimap-query-article-no-from-file nil |
58 | "If non-nil, `org-gnus-follow-link' will try to translate | |
59 | Message-Ids to article numbers by querying the .overview file. | |
60 | Normally, this translation is done by querying the IMAP server, | |
61 | which is usually very fast. Unfortunately, some (maybe badly | |
62 | configured) IMAP servers don't support this operation quickly. | |
63 | So if following a link to a Gnus article takes ages, try setting | |
64 | this variable to `t'." | |
65 | :group 'org-link-store | |
372d7b21 | 66 | :version "24.1" |
afe98dfa CD |
67 | :type 'boolean) |
68 | ||
20908596 CD |
69 | |
70 | ;; Install the link type | |
71 | (org-add-link-type "gnus" 'org-gnus-open) | |
72 | (add-hook 'org-store-link-functions 'org-gnus-store-link) | |
73 | ||
74 | ;; Implementation | |
ce4fdcb9 | 75 | |
afe98dfa CD |
76 | (defun org-gnus-nnimap-cached-article-number (group server message-id) |
77 | "Return cached article number (uid) of message in GROUP on SERVER. | |
78 | MESSAGE-ID is the message-id header field that identifies the | |
79 | message. If the uid is not cached, return nil." | |
80 | (with-temp-buffer | |
81 | (let ((nov (nnimap-group-overview-filename group server))) | |
82 | (when (file-exists-p nov) | |
83 | (mm-insert-file-contents nov) | |
84 | (set-buffer-modified-p nil) | |
85 | (goto-char (point-min)) | |
86 | (catch 'found | |
87 | (while (search-forward message-id nil t) | |
88 | (let ((hdr (split-string (thing-at-point 'line) "\t"))) | |
89 | (if (string= (nth 4 hdr) message-id) | |
90 | (throw 'found (nth 0 hdr)))))))))) | |
91 | ||
ce4fdcb9 CD |
92 | (defun org-gnus-group-link (group) |
93 | "Create a link to the Gnus group GROUP. | |
94 | If GROUP is a newsgroup and `org-gnus-prefer-web-links' is | |
95 | non-nil, create a link to groups.google.com or gmane.org. | |
96 | Otherwise create a link to the group inside Gnus. | |
97 | ||
98 | If `org-store-link' was called with a prefix arg the meaning of | |
99 | `org-gnus-prefer-web-links' is reversed." | |
100 | (let ((unprefixed-group (replace-regexp-in-string "^[^:]+:" "" group))) | |
101 | (if (and (string-match "^nntp" group) ;; Only for nntp groups | |
102 | (org-xor current-prefix-arg | |
103 | org-gnus-prefer-web-links)) | |
8223b1d2 BG |
104 | (concat (if (string-match "gmane" unprefixed-group) |
105 | "http://news.gmane.org/" | |
106 | "http://groups.google.com/group/") | |
107 | unprefixed-group) | |
108 | (concat "gnus:" group)))) | |
ce4fdcb9 CD |
109 | |
110 | (defun org-gnus-article-link (group newsgroups message-id x-no-archive) | |
111 | "Create a link to a Gnus article. | |
112 | The article is specified by its MESSAGE-ID. Additional | |
113 | parameters are the Gnus GROUP, the NEWSGROUPS the article was | |
114 | posted to and the X-NO-ARCHIVE header value of that article. | |
115 | ||
116 | If GROUP is a newsgroup and `org-gnus-prefer-web-links' is | |
117 | non-nil, create a link to groups.google.com or gmane.org. | |
118 | Otherwise create a link to the article inside Gnus. | |
119 | ||
120 | If `org-store-link' was called with a prefix arg the meaning of | |
121 | `org-gnus-prefer-web-links' is reversed." | |
122 | (if (and (org-xor current-prefix-arg org-gnus-prefer-web-links) | |
123 | newsgroups ;; Make web links only for nntp groups | |
124 | (not x-no-archive)) ;; and if X-No-Archive isn't set. | |
125 | (format (if (string-match "gmane\\." newsgroups) | |
126 | "http://mid.gmane.org/%s" | |
127 | "http://groups.google.com/groups/search?as_umsgid=%s") | |
db55f368 | 128 | (org-fixup-message-id-for-http message-id)) |
8223b1d2 | 129 | (concat "gnus:" group "#" message-id))) |
ce4fdcb9 | 130 | |
20908596 CD |
131 | (defun org-gnus-store-link () |
132 | "Store a link to a Gnus folder or message." | |
133 | (cond | |
134 | ((eq major-mode 'gnus-group-mode) | |
ce4fdcb9 CD |
135 | (let* ((group (cond ((fboundp 'gnus-group-group-name) ; depending on Gnus |
136 | (gnus-group-group-name)) ; version | |
137 | ((fboundp 'gnus-group-name) | |
138 | (gnus-group-name)) | |
139 | (t "???"))) | |
140 | desc link) | |
0bd48b37 CD |
141 | (when group |
142 | (org-store-link-props :type "gnus" :group group) | |
143 | (setq desc (org-gnus-group-link group) | |
144 | link desc) | |
145 | (org-add-link-props :link link :description desc) | |
146 | link))) | |
20908596 CD |
147 | |
148 | ((memq major-mode '(gnus-summary-mode gnus-article-mode)) | |
20908596 | 149 | (let* ((group gnus-newsgroup-name) |
86fbb8ca | 150 | (header (with-current-buffer gnus-summary-buffer |
54a0dee5 CD |
151 | (gnus-summary-article-header))) |
152 | (from (mail-header-from header)) | |
153 | (message-id (org-remove-angle-brackets (mail-header-id header))) | |
3ab2c837 BG |
154 | (date (org-trim (mail-header-date header))) |
155 | (date-ts (and date | |
156 | (ignore-errors | |
157 | (format-time-string | |
158 | (org-time-stamp-format t) | |
159 | (date-to-time date))))) | |
160 | (date-ts-ia (and date | |
161 | (ignore-errors | |
162 | (format-time-string | |
163 | (org-time-stamp-format t t) | |
164 | (date-to-time date))))) | |
86fbb8ca CD |
165 | (subject (copy-sequence (mail-header-subject header))) |
166 | (to (cdr (assq 'To (mail-header-extra header)))) | |
167 | newsgroups x-no-archive desc link) | |
168 | ;; Remove text properties of subject string to avoid Emacs bug | |
169 | ;; #3506 | |
170 | (set-text-properties 0 (length subject) nil subject) | |
171 | ||
54a0dee5 CD |
172 | ;; Fetching an article is an expensive operation; newsgroup and |
173 | ;; x-no-archive are only needed for web links. | |
174 | (when (org-xor current-prefix-arg org-gnus-prefer-web-links) | |
86fbb8ca CD |
175 | ;; Make sure the original article buffer is up-to-date |
176 | (save-window-excursion (gnus-summary-select-article)) | |
177 | (setq to (or to (gnus-fetch-original-field "To")) | |
178 | newsgroups (gnus-fetch-original-field "Newsgroups") | |
179 | x-no-archive (gnus-fetch-original-field "x-no-archive"))) | |
14e1337f | 180 | (org-store-link-props :type "gnus" :from from :subject subject |
621f83e4 | 181 | :message-id message-id :group group :to to) |
afe98dfa CD |
182 | (when date |
183 | (org-add-link-props :date date :date-timestamp date-ts | |
184 | :date-timestamp-inactive date-ts-ia)) | |
ce4fdcb9 | 185 | (setq desc (org-email-link-description) |
54a0dee5 CD |
186 | link (org-gnus-article-link |
187 | group newsgroups message-id x-no-archive)) | |
20908596 | 188 | (org-add-link-props :link link :description desc) |
3ab2c837 BG |
189 | link)) |
190 | ((eq major-mode 'message-mode) | |
191 | (setq org-store-link-plist nil) ; reset | |
192 | (save-excursion | |
193 | (save-restriction | |
194 | (message-narrow-to-headers) | |
195 | (and (not (message-fetch-field "Message-ID")) | |
196 | (message-generate-headers '(Message-ID))) | |
197 | (goto-char (point-min)) | |
198 | (re-search-forward "^Message-ID: *.*$" nil t) | |
199 | (put-text-property (match-beginning 0) (match-end 0) 'message-deletable nil) | |
200 | (let ((gcc (car (last | |
201 | (message-unquote-tokens | |
202 | (message-tokenize-header (mail-fetch-field "gcc" nil t) " ,"))))) | |
203 | (id (org-remove-angle-brackets (mail-fetch-field "Message-ID"))) | |
204 | (to (mail-fetch-field "To")) | |
205 | (from (mail-fetch-field "From")) | |
206 | (subject (mail-fetch-field "Subject")) | |
207 | desc link | |
208 | newsgroup xarchive) ; those are always nil for gcc | |
209 | (and (not gcc) | |
8223b1d2 | 210 | (error "Can not create link: No Gcc header found")) |
3ab2c837 BG |
211 | (org-store-link-props :type "gnus" :from from :subject subject |
212 | :message-id id :group gcc :to to) | |
213 | (setq desc (org-email-link-description) | |
214 | link (org-gnus-article-link | |
215 | gcc newsgroup id xarchive)) | |
216 | (org-add-link-props :link link :description desc) | |
217 | link)))))) | |
20908596 | 218 | |
afe98dfa CD |
219 | (defun org-gnus-open-nntp (path) |
220 | "Follow the nntp: link specified by PATH." | |
221 | (let* ((spec (split-string path "/")) | |
222 | (server (split-string (nth 2 spec) "@")) | |
223 | (group (nth 3 spec)) | |
224 | (article (nth 4 spec))) | |
225 | (org-gnus-follow-link | |
226 | (format "nntp+%s:%s" (or (cdr server) (car server)) group) | |
227 | article))) | |
228 | ||
20908596 CD |
229 | (defun org-gnus-open (path) |
230 | "Follow the Gnus message or folder link specified by PATH." | |
231 | (let (group article) | |
232 | (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) | |
233 | (error "Error in Gnus link")) | |
234 | (setq group (match-string 1 path) | |
235 | article (match-string 3 path)) | |
db55f368 | 236 | (when group |
8223b1d2 | 237 | (setq group (org-no-properties group))) |
db55f368 | 238 | (when article |
8223b1d2 | 239 | (setq article (org-no-properties article))) |
20908596 CD |
240 | (org-gnus-follow-link group article))) |
241 | ||
242 | (defun org-gnus-follow-link (&optional group article) | |
243 | "Follow a Gnus link to GROUP and ARTICLE." | |
244 | (require 'gnus) | |
245 | (funcall (cdr (assq 'gnus org-link-frame-setup))) | |
246 | (if gnus-other-frame-object (select-frame gnus-other-frame-object)) | |
db55f368 | 247 | (when group |
8223b1d2 | 248 | (setq group (org-no-properties group))) |
db55f368 | 249 | (when article |
8223b1d2 | 250 | (setq article (org-no-properties article))) |
20908596 | 251 | (cond ((and group article) |
3ab2c837 | 252 | (gnus-activate-group group) |
db55f368 | 253 | (condition-case nil |
afe98dfa CD |
254 | (let* ((method (gnus-find-method-for-group group)) |
255 | (backend (car method)) | |
256 | (server (cadr method))) | |
ed21c5c8 CD |
257 | (cond |
258 | ((eq backend 'nndoc) | |
259 | (if (gnus-group-read-group t nil group) | |
260 | (gnus-summary-goto-article article nil t) | |
261 | (message "Couldn't follow gnus link. %s" | |
262 | "The summary couldn't be opened."))) | |
263 | (t | |
264 | (let ((articles 1) | |
265 | group-opened) | |
afe98dfa CD |
266 | (when (and (eq backend 'nnimap) |
267 | org-gnus-nnimap-query-article-no-from-file) | |
268 | (setq article | |
269 | (or (org-gnus-nnimap-cached-article-number | |
270 | (nth 1 (split-string group ":")) | |
271 | server (concat "<" article ">")) article))) | |
ed21c5c8 CD |
272 | (while (and (not group-opened) |
273 | ;; stop on integer overflows | |
274 | (> articles 0)) | |
275 | (setq group-opened (gnus-group-read-group | |
8223b1d2 | 276 | articles t group) |
ed21c5c8 CD |
277 | articles (if (< articles 16) |
278 | (1+ articles) | |
279 | (* articles 2)))) | |
280 | (if group-opened | |
281 | (gnus-summary-goto-article article nil t) | |
282 | (message "Couldn't follow gnus link. %s" | |
283 | "The summary couldn't be opened.")))))) | |
db55f368 CD |
284 | (quit (message "Couldn't follow gnus link. %s" |
285 | "The linked group is empty.")))) | |
20908596 CD |
286 | (group (gnus-group-jump-to-group group)))) |
287 | ||
93b62de8 CD |
288 | (defun org-gnus-no-new-news () |
289 | "Like `M-x gnus' but doesn't check for new news." | |
290 | (if (not (gnus-alive-p)) (gnus))) | |
291 | ||
20908596 CD |
292 | (provide 'org-gnus) |
293 | ||
5b409b39 | 294 | |
20908596 | 295 | ;;; org-gnus.el ends here |