Refill some long/short copyright headers.
[bpt/emacs.git] / lisp / org / org-gnus.el
CommitLineData
20908596
CD
1;;; org-gnus.el --- Support for links to Gnus groups and messages from within Org-mode
2
95df8112 3;; Copyright (C) 2004-2011 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
acedf35c 9;; Version: 7.4
20908596
CD
10;;
11;; This file is part of GNU Emacs.
12;;
b1fc2b50 13;; GNU Emacs is free software: you can redistribute it and/or modify
20908596 14;; it under the terms of the GNU General Public License as published by
b1fc2b50
GM
15;; the Free Software Foundation, either version 3 of the License, or
16;; (at your option) any later version.
20908596
CD
17
18;; GNU Emacs is distributed in the hope that it will be useful,
19;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21;; GNU General Public License for more details.
22
23;; You should have received a copy of the GNU General Public License
b1fc2b50 24;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
20908596
CD
25;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
26;;
27;;; Commentary:
28
29;; This file implements links to Gnus groups and messages from within Org-mode.
30;; Org-mode loads this module by default - if this is not what you want,
31;; configure the variable `org-modules'.
32
33;;; Code:
34
35(require 'org)
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
51When nil, Gnus will be used for such links.
52Using a prefix arg to the command \\[org-store-link] (`org-store-link')
53negates 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
59Message-Ids to article numbers by querying the .overview file.
60Normally, this translation is done by querying the IMAP server,
61which is usually very fast. Unfortunately, some (maybe badly
62configured) IMAP servers don't support this operation quickly.
63So if following a link to a Gnus article takes ages, try setting
64this variable to `t'."
65 :group 'org-link-store
66 :type 'boolean)
67
20908596
CD
68
69;; Install the link type
70(org-add-link-type "gnus" 'org-gnus-open)
71(add-hook 'org-store-link-functions 'org-gnus-store-link)
72
73;; Implementation
ce4fdcb9 74
afe98dfa
CD
75(defun org-gnus-nnimap-cached-article-number (group server message-id)
76 "Return cached article number (uid) of message in GROUP on SERVER.
77MESSAGE-ID is the message-id header field that identifies the
78message. If the uid is not cached, return nil."
79 (with-temp-buffer
80 (let ((nov (nnimap-group-overview-filename group server)))
81 (when (file-exists-p nov)
82 (mm-insert-file-contents nov)
83 (set-buffer-modified-p nil)
84 (goto-char (point-min))
85 (catch 'found
86 (while (search-forward message-id nil t)
87 (let ((hdr (split-string (thing-at-point 'line) "\t")))
88 (if (string= (nth 4 hdr) message-id)
89 (throw 'found (nth 0 hdr))))))))))
90
ce4fdcb9
CD
91(defun org-gnus-group-link (group)
92 "Create a link to the Gnus group GROUP.
93If GROUP is a newsgroup and `org-gnus-prefer-web-links' is
94non-nil, create a link to groups.google.com or gmane.org.
95Otherwise create a link to the group inside Gnus.
96
97If `org-store-link' was called with a prefix arg the meaning of
98`org-gnus-prefer-web-links' is reversed."
99 (let ((unprefixed-group (replace-regexp-in-string "^[^:]+:" "" group)))
100 (if (and (string-match "^nntp" group) ;; Only for nntp groups
101 (org-xor current-prefix-arg
102 org-gnus-prefer-web-links))
db55f368
CD
103 (org-make-link (if (string-match "gmane" unprefixed-group)
104 "http://news.gmane.org/"
105 "http://groups.google.com/group/")
106 unprefixed-group)
107 (org-make-link "gnus:" group))))
ce4fdcb9
CD
108
109(defun org-gnus-article-link (group newsgroups message-id x-no-archive)
110 "Create a link to a Gnus article.
111The article is specified by its MESSAGE-ID. Additional
112parameters are the Gnus GROUP, the NEWSGROUPS the article was
113posted to and the X-NO-ARCHIVE header value of that article.
114
115If GROUP is a newsgroup and `org-gnus-prefer-web-links' is
116non-nil, create a link to groups.google.com or gmane.org.
117Otherwise create a link to the article inside Gnus.
118
119If `org-store-link' was called with a prefix arg the meaning of
120`org-gnus-prefer-web-links' is reversed."
121 (if (and (org-xor current-prefix-arg org-gnus-prefer-web-links)
122 newsgroups ;; Make web links only for nntp groups
123 (not x-no-archive)) ;; and if X-No-Archive isn't set.
124 (format (if (string-match "gmane\\." newsgroups)
125 "http://mid.gmane.org/%s"
126 "http://groups.google.com/groups/search?as_umsgid=%s")
db55f368 127 (org-fixup-message-id-for-http message-id))
ce4fdcb9
CD
128 (org-make-link "gnus:" group "#" message-id)))
129
20908596
CD
130(defun org-gnus-store-link ()
131 "Store a link to a Gnus folder or message."
132 (cond
133 ((eq major-mode 'gnus-group-mode)
ce4fdcb9
CD
134 (let* ((group (cond ((fboundp 'gnus-group-group-name) ; depending on Gnus
135 (gnus-group-group-name)) ; version
136 ((fboundp 'gnus-group-name)
137 (gnus-group-name))
138 (t "???")))
139 desc link)
0bd48b37
CD
140 (when group
141 (org-store-link-props :type "gnus" :group group)
142 (setq desc (org-gnus-group-link group)
143 link desc)
144 (org-add-link-props :link link :description desc)
145 link)))
20908596
CD
146
147 ((memq major-mode '(gnus-summary-mode gnus-article-mode))
20908596 148 (let* ((group gnus-newsgroup-name)
86fbb8ca 149 (header (with-current-buffer gnus-summary-buffer
54a0dee5
CD
150 (gnus-summary-article-header)))
151 (from (mail-header-from header))
152 (message-id (org-remove-angle-brackets (mail-header-id header)))
153 (date (mail-header-date header))
afe98dfa
CD
154 (date-ts (and date (format-time-string
155 (org-time-stamp-format t) (date-to-time date))))
156 (date-ts-ia (and date (format-time-string
157 (org-time-stamp-format t t)
158 (date-to-time date))))
86fbb8ca
CD
159 (subject (copy-sequence (mail-header-subject header)))
160 (to (cdr (assq 'To (mail-header-extra header))))
161 newsgroups x-no-archive desc link)
162 ;; Remove text properties of subject string to avoid Emacs bug
163 ;; #3506
164 (set-text-properties 0 (length subject) nil subject)
165
54a0dee5
CD
166 ;; Fetching an article is an expensive operation; newsgroup and
167 ;; x-no-archive are only needed for web links.
168 (when (org-xor current-prefix-arg org-gnus-prefer-web-links)
86fbb8ca
CD
169 ;; Make sure the original article buffer is up-to-date
170 (save-window-excursion (gnus-summary-select-article))
171 (setq to (or to (gnus-fetch-original-field "To"))
172 newsgroups (gnus-fetch-original-field "Newsgroups")
173 x-no-archive (gnus-fetch-original-field "x-no-archive")))
afe98dfa 174 (org-store-link-props :type "gnus" :from from :subject subject
621f83e4 175 :message-id message-id :group group :to to)
afe98dfa
CD
176 (when date
177 (org-add-link-props :date date :date-timestamp date-ts
178 :date-timestamp-inactive date-ts-ia))
ce4fdcb9 179 (setq desc (org-email-link-description)
54a0dee5
CD
180 link (org-gnus-article-link
181 group newsgroups message-id x-no-archive))
20908596
CD
182 (org-add-link-props :link link :description desc)
183 link))))
184
afe98dfa
CD
185(defun org-gnus-open-nntp (path)
186 "Follow the nntp: link specified by PATH."
187 (let* ((spec (split-string path "/"))
188 (server (split-string (nth 2 spec) "@"))
189 (group (nth 3 spec))
190 (article (nth 4 spec)))
191 (org-gnus-follow-link
192 (format "nntp+%s:%s" (or (cdr server) (car server)) group)
193 article)))
194
20908596
CD
195(defun org-gnus-open (path)
196 "Follow the Gnus message or folder link specified by PATH."
197 (let (group article)
198 (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path))
199 (error "Error in Gnus link"))
200 (setq group (match-string 1 path)
201 article (match-string 3 path))
db55f368
CD
202 (when group
203 (setq group (org-substring-no-properties group)))
204 (when article
205 (setq article (org-substring-no-properties article)))
20908596
CD
206 (org-gnus-follow-link group article)))
207
208(defun org-gnus-follow-link (&optional group article)
209 "Follow a Gnus link to GROUP and ARTICLE."
210 (require 'gnus)
211 (funcall (cdr (assq 'gnus org-link-frame-setup)))
212 (if gnus-other-frame-object (select-frame gnus-other-frame-object))
db55f368
CD
213 (when group
214 (setq group (org-substring-no-properties group)))
215 (when article
216 (setq article (org-substring-no-properties article)))
20908596 217 (cond ((and group article)
db55f368
CD
218 (gnus-activate-group group t)
219 (condition-case nil
afe98dfa
CD
220 (let* ((method (gnus-find-method-for-group group))
221 (backend (car method))
222 (server (cadr method)))
ed21c5c8
CD
223 (cond
224 ((eq backend 'nndoc)
225 (if (gnus-group-read-group t nil group)
226 (gnus-summary-goto-article article nil t)
227 (message "Couldn't follow gnus link. %s"
228 "The summary couldn't be opened.")))
229 (t
230 (let ((articles 1)
231 group-opened)
afe98dfa
CD
232 (when (and (eq backend 'nnimap)
233 org-gnus-nnimap-query-article-no-from-file)
234 (setq article
235 (or (org-gnus-nnimap-cached-article-number
236 (nth 1 (split-string group ":"))
237 server (concat "<" article ">")) article)))
ed21c5c8
CD
238 (while (and (not group-opened)
239 ;; stop on integer overflows
240 (> articles 0))
241 (setq group-opened (gnus-group-read-group
242 articles nil group)
243 articles (if (< articles 16)
244 (1+ articles)
245 (* articles 2))))
246 (if group-opened
247 (gnus-summary-goto-article article nil t)
248 (message "Couldn't follow gnus link. %s"
249 "The summary couldn't be opened."))))))
db55f368
CD
250 (quit (message "Couldn't follow gnus link. %s"
251 "The linked group is empty."))))
20908596
CD
252 (group (gnus-group-jump-to-group group))))
253
93b62de8
CD
254(defun org-gnus-no-new-news ()
255 "Like `M-x gnus' but doesn't check for new news."
256 (if (not (gnus-alive-p)) (gnus)))
257
20908596
CD
258(provide 'org-gnus)
259
b349f79f 260
20908596 261;;; org-gnus.el ends here