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