Commit | Line | Data |
---|---|---|
20908596 CD |
1 | ;;; org-wl.el --- Support for links to Wanderlust messages from within Org-mode |
2 | ||
73b0cd50 | 3 | ;; Copyright (C) 2004-2011 |
1e4f816a | 4 | ;; Free Software Foundation, Inc. |
20908596 CD |
5 | |
6 | ;; Author: Tokuya Kameshima <kames at fa2 dot so-net dot ne dot jp> | |
86fbb8ca | 7 | ;; David Maus <dmaus at ictsoc dot de> |
20908596 CD |
8 | ;; Keywords: outlines, hypermedia, calendar, wp |
9 | ;; Homepage: http://orgmode.org | |
acedf35c | 10 | ;; Version: 7.4 |
20908596 CD |
11 | ;; |
12 | ;; This file is part of GNU Emacs. | |
13 | ;; | |
b1fc2b50 | 14 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
20908596 | 15 | ;; it under the terms of the GNU General Public License as published by |
b1fc2b50 GM |
16 | ;; the Free Software Foundation, either version 3 of the License, or |
17 | ;; (at your option) any later version. | |
20908596 CD |
18 | |
19 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
20 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
21 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
22 | ;; GNU General Public License for more details. | |
23 | ||
24 | ;; You should have received a copy of the GNU General Public License | |
b1fc2b50 | 25 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
20908596 CD |
26 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
27 | ;; | |
28 | ;;; Commentary: | |
29 | ||
30 | ;; This file implements links to Wanderlust messages from within Org-mode. | |
31 | ;; Org-mode loads this module by default - if this is not what you want, | |
32 | ;; configure the variable `org-modules'. | |
33 | ||
34 | ;;; Code: | |
35 | ||
36 | (require 'org) | |
37 | ||
38 | (defgroup org-wl nil | |
39 | "Options concerning the Wanderlust link." | |
40 | :tag "Org Startup" | |
41 | :group 'org-link) | |
42 | ||
43 | (defcustom org-wl-link-to-refile-destination t | |
86fbb8ca CD |
44 | "Create a link to the refile destination if the message is marked as refile." |
45 | :group 'org-wl | |
46 | :type 'boolean) | |
47 | ||
48 | (defcustom org-wl-link-remove-filter nil | |
49 | "Remove filter condition if message is filter folder." | |
50 | :group 'org-wl | |
51 | :type 'boolean) | |
52 | ||
53 | (defcustom org-wl-shimbun-prefer-web-links nil | |
54 | "If non-nil create web links for shimbun messages." | |
55 | :group 'org-wl | |
56 | :type 'boolean) | |
57 | ||
58 | (defcustom org-wl-nntp-prefer-web-links nil | |
59 | "If non-nil create web links for nntp messages. | |
60 | When folder name contains string \"gmane\" link to gmane, | |
61 | googlegroups otherwise." | |
62 | :type 'boolean | |
63 | :group 'org-wl) | |
64 | ||
65 | (defcustom org-wl-disable-folder-check t | |
66 | "Disable check for new messages when open a link." | |
67 | :type 'boolean | |
68 | :group 'org-wl) | |
69 | ||
70 | (defcustom org-wl-namazu-default-index nil | |
71 | "Default namazu search index." | |
72 | :type 'directory | |
73 | :group 'org-wl) | |
20908596 CD |
74 | |
75 | ;; Declare external functions and variables | |
76 | (declare-function elmo-folder-exists-p "ext:elmo" (folder) t) | |
77 | (declare-function elmo-message-entity-field "ext:elmo-msgdb" | |
78 | (entity field &optional type)) | |
79 | (declare-function elmo-message-field "ext:elmo" | |
80 | (folder number field &optional type) t) | |
81 | (declare-function elmo-msgdb-overview-get-entity "ext:elmo" (id msgdb) t) | |
82 | ;; Backward compatibility to old version of wl | |
83 | (declare-function wl "ext:wl" () t) | |
84 | (declare-function wl-summary-buffer-msgdb "ext:wl-folder" () t) | |
20908596 CD |
85 | (declare-function wl-summary-jump-to-msg-by-message-id "ext:wl-summary" |
86 | (&optional id)) | |
afe98dfa CD |
87 | (declare-function wl-summary-jump-to-msg "ext:wl-summary" |
88 | (&optional number beg end)) | |
20908596 CD |
89 | (declare-function wl-summary-line-from "ext:wl-summary" ()) |
90 | (declare-function wl-summary-line-subject "ext:wl-summary" ()) | |
91 | (declare-function wl-summary-message-number "ext:wl-summary" ()) | |
92 | (declare-function wl-summary-redisplay "ext:wl-summary" (&optional arg)) | |
93 | (declare-function wl-summary-registered-temp-mark "ext:wl-action" (number)) | |
94 | (declare-function wl-folder-goto-folder-subr "ext:wl-folder" | |
95 | (&optional folder sticky)) | |
86fbb8ca CD |
96 | (declare-function wl-folder-get-petname "ext:wl-folder" (name)) |
97 | (declare-function wl-folder-get-entity-from-buffer "ext:wl-folder" | |
98 | (&optional getid)) | |
99 | (declare-function wl-folder-buffer-group-p "ext:wl-folder") | |
20908596 CD |
100 | (defvar wl-init) |
101 | (defvar wl-summary-buffer-elmo-folder) | |
102 | (defvar wl-summary-buffer-folder-name) | |
86fbb8ca CD |
103 | (defvar wl-folder-group-regexp) |
104 | (defvar wl-auto-check-folder-name) | |
afe98dfa | 105 | (defvar elmo-nntp-default-server) |
86fbb8ca CD |
106 | |
107 | (defconst org-wl-folder-types | |
108 | '(("%" . imap) ("-" . nntp) ("+" . mh) ("=" . spool) | |
109 | ("$" . archive) ("&" . pop) ("@" . shimbun) ("[" . search) | |
110 | ("*" . multi) ("/" . filter) ("|" . pipe) ("'" . internal)) | |
111 | "List of folder indicators. See Wanderlust manual, section 3.") | |
20908596 CD |
112 | |
113 | ;; Install the link type | |
114 | (org-add-link-type "wl" 'org-wl-open) | |
115 | (add-hook 'org-store-link-functions 'org-wl-store-link) | |
116 | ||
117 | ;; Implementation | |
86fbb8ca CD |
118 | |
119 | (defun org-wl-folder-type (folder) | |
120 | "Return symbol that indicates the type of FOLDER. | |
121 | FOLDER is the wanderlust folder name. The first character of the | |
122 | folder name determines the the folder type." | |
123 | (let* ((indicator (substring folder 0 1)) | |
124 | (type (cdr (assoc indicator org-wl-folder-types)))) | |
125 | ;; maybe access or file folder | |
126 | (when (not type) | |
127 | (setq type | |
128 | (cond | |
129 | ((and (>= (length folder) 5) | |
130 | (string= (substring folder 0 5) "file:")) | |
131 | 'file) | |
132 | ((and (>= (length folder) 7) | |
133 | (string= (substring folder 0 7) "access:")) | |
134 | 'access) | |
135 | (t | |
136 | nil)))) | |
137 | type)) | |
138 | ||
139 | (defun org-wl-message-field (field entity) | |
140 | "Return content of FIELD in ENTITY. | |
141 | FIELD is a symbol of a rfc822 message header field. | |
142 | ENTITY is a message entity." | |
afe98dfa | 143 | (let ((content (elmo-message-entity-field entity field 'string))) |
86fbb8ca CD |
144 | (if (listp content) (car content) content))) |
145 | ||
20908596 | 146 | (defun org-wl-store-link () |
86fbb8ca | 147 | "Store a link to a WL message or folder." |
afe98dfa CD |
148 | (unless (eobp) |
149 | (cond | |
150 | ((memq major-mode '(wl-summary-mode mime-view-mode)) | |
151 | (org-wl-store-link-message)) | |
152 | ((eq major-mode 'wl-folder-mode) | |
153 | (org-wl-store-link-folder)) | |
154 | (t | |
155 | nil)))) | |
86fbb8ca CD |
156 | |
157 | (defun org-wl-store-link-folder () | |
158 | "Store a link to a WL folder." | |
159 | (let* ((folder (wl-folder-get-entity-from-buffer)) | |
160 | (petname (wl-folder-get-petname folder)) | |
161 | (link (org-make-link "wl:" folder))) | |
162 | (save-excursion | |
163 | (beginning-of-line) | |
164 | (unless (and (wl-folder-buffer-group-p) | |
165 | (looking-at wl-folder-group-regexp)) | |
166 | (org-store-link-props :type "wl" :description petname | |
167 | :link link) | |
168 | link)))) | |
169 | ||
170 | (defun org-wl-store-link-message () | |
171 | "Store a link to a WL message." | |
172 | (save-excursion | |
173 | (let ((buf (if (eq major-mode 'wl-summary-mode) | |
174 | (current-buffer) | |
175 | (and (boundp 'wl-message-buffer-cur-summary-buffer) | |
176 | wl-message-buffer-cur-summary-buffer)))) | |
177 | (when buf | |
178 | (with-current-buffer buf | |
179 | (let* ((msgnum (wl-summary-message-number)) | |
180 | (mark-info (wl-summary-registered-temp-mark msgnum)) | |
181 | (folder-name | |
182 | (if (and org-wl-link-to-refile-destination | |
183 | mark-info | |
184 | (equal (nth 1 mark-info) "o")) ; marked as refile | |
185 | (nth 2 mark-info) | |
186 | wl-summary-buffer-folder-name)) | |
187 | (folder-type (org-wl-folder-type folder-name)) | |
188 | (wl-message-entity | |
189 | (if (fboundp 'elmo-message-entity) | |
190 | (elmo-message-entity | |
191 | wl-summary-buffer-elmo-folder msgnum) | |
192 | (elmo-msgdb-overview-get-entity | |
193 | msgnum (wl-summary-buffer-msgdb)))) | |
194 | (message-id | |
195 | (org-wl-message-field 'message-id wl-message-entity)) | |
afe98dfa CD |
196 | (message-id-no-brackets |
197 | (org-remove-angle-brackets message-id)) | |
86fbb8ca CD |
198 | (from (org-wl-message-field 'from wl-message-entity)) |
199 | (to (org-wl-message-field 'to wl-message-entity)) | |
200 | (xref (org-wl-message-field 'xref wl-message-entity)) | |
201 | (subject (org-wl-message-field 'subject wl-message-entity)) | |
afe98dfa CD |
202 | (date (org-wl-message-field 'date wl-message-entity)) |
203 | (date-ts (and date (format-time-string | |
204 | (org-time-stamp-format t) | |
205 | (date-to-time date)))) | |
206 | (date-ts-ia (and date (format-time-string | |
207 | (org-time-stamp-format t t) | |
208 | (date-to-time date)))) | |
86fbb8ca CD |
209 | desc link) |
210 | ||
211 | ;; remove text properties of subject string to avoid possible bug | |
212 | ;; when formatting the subject | |
213 | ;; (Emacs bug #5306, fixed) | |
214 | (set-text-properties 0 (length subject) nil subject) | |
215 | ||
216 | ;; maybe remove filter condition | |
217 | (when (and (eq folder-type 'filter) org-wl-link-remove-filter) | |
218 | (while (eq (org-wl-folder-type folder-name) 'filter) | |
219 | (setq folder-name | |
220 | (replace-regexp-in-string "^/[^/]+/" "" folder-name)))) | |
221 | ||
222 | ;; maybe create http link | |
223 | (cond | |
224 | ((and (eq folder-type 'shimbun) | |
225 | org-wl-shimbun-prefer-web-links xref) | |
226 | (org-store-link-props :type "http" :link xref :description subject | |
227 | :from from :to to :message-id message-id | |
afe98dfa | 228 | :message-id-no-brackets message-id-no-brackets |
86fbb8ca CD |
229 | :subject subject)) |
230 | ((and (eq folder-type 'nntp) org-wl-nntp-prefer-web-links) | |
231 | (setq link | |
232 | (format | |
233 | (if (string-match "gmane\\." folder-name) | |
234 | "http://mid.gmane.org/%s" | |
235 | "http://groups.google.com/groups/search?as_umsgid=%s") | |
236 | (org-fixup-message-id-for-http message-id))) | |
237 | (org-store-link-props :type "http" :link link :description subject | |
238 | :from from :to to :message-id message-id | |
afe98dfa | 239 | :message-id-no-brackets message-id-no-brackets |
86fbb8ca CD |
240 | :subject subject)) |
241 | (t | |
242 | (org-store-link-props :type "wl" :from from :to to | |
afe98dfa CD |
243 | :subject subject :message-id message-id |
244 | :message-id-no-brackets message-id-no-brackets) | |
86fbb8ca | 245 | (setq desc (org-email-link-description)) |
afe98dfa | 246 | (setq link (org-make-link "wl:" folder-name "#" message-id-no-brackets)) |
86fbb8ca | 247 | (org-add-link-props :link link :description desc))) |
afe98dfa CD |
248 | (when date |
249 | (org-add-link-props :date date :date-timestamp date-ts | |
250 | :date-timestamp-inactive date-ts-ia)) | |
86fbb8ca | 251 | (or link xref))))))) |
20908596 | 252 | |
afe98dfa CD |
253 | (defun org-wl-open-nntp (path) |
254 | "Follow the nntp: link specified by PATH." | |
255 | (let* ((spec (split-string path "/")) | |
256 | (server (split-string (nth 2 spec) "@")) | |
257 | (group (nth 3 spec)) | |
258 | (article (nth 4 spec))) | |
259 | (org-wl-open | |
260 | (concat "-" group ":" (if (cdr server) | |
261 | (car (split-string (car server) ":")) | |
262 | "") | |
263 | (if (string= elmo-nntp-default-server (nth 2 spec)) | |
264 | "" | |
265 | (concat "@" (or (cdr server) (car server)))) | |
266 | (if article (concat "#" article) ""))))) | |
267 | ||
20908596 | 268 | (defun org-wl-open (path) |
86fbb8ca CD |
269 | "Follow the WL message link specified by PATH. |
270 | When called with one prefix, open message in namazu search folder | |
271 | with `org-wl-namazu-default-index' as search index. When called | |
272 | with two prefixes or `org-wl-namazu-default-index' is nil, ask | |
273 | for namazu index." | |
274 | (require 'wl) | |
275 | (let ((wl-auto-check-folder-name | |
276 | (if org-wl-disable-folder-check | |
277 | 'none | |
278 | wl-auto-check-folder-name))) | |
279 | (unless wl-init (wl)) | |
280 | ;; XXX: The imap-uw's MH folder names start with "%#". | |
281 | (if (not (string-match "\\`\\(\\(?:%#\\)?[^#]+\\)\\(#\\(.*\\)\\)?" path)) | |
282 | (error "Error in Wanderlust link")) | |
283 | (let ((folder (match-string 1 path)) | |
284 | (article (match-string 3 path))) | |
285 | ;; maybe open message in namazu search folder | |
286 | (when current-prefix-arg | |
287 | (setq folder (concat "[" article "]" | |
288 | (if (and (equal current-prefix-arg '(4)) | |
289 | org-wl-namazu-default-index) | |
290 | org-wl-namazu-default-index | |
291 | (read-directory-name "Namazu index: "))))) | |
292 | (if (not (elmo-folder-exists-p (org-no-warnings | |
293 | (wl-folder-get-elmo-folder folder)))) | |
294 | (error "No such folder: %s" folder)) | |
295 | (let ((old-buf (current-buffer)) | |
296 | (old-point (point-marker))) | |
297 | (wl-folder-goto-folder-subr folder) | |
298 | (with-current-buffer old-buf | |
299 | ;; XXX: `wl-folder-goto-folder-subr' moves point to the | |
300 | ;; beginning of the current line. So, restore the point | |
301 | ;; in the old buffer. | |
302 | (goto-char old-point)) | |
afe98dfa CD |
303 | (when article |
304 | (if (org-string-match-p "@" article) | |
305 | (wl-summary-jump-to-msg-by-message-id (org-add-angle-brackets | |
306 | article)) | |
307 | (or (wl-summary-jump-to-msg (string-to-number article)) | |
308 | (error "No such message: %s" article))) | |
86fbb8ca | 309 | (wl-summary-redisplay)))))) |
20908596 CD |
310 | |
311 | (provide 'org-wl) | |
312 | ||
b349f79f | 313 | |
20908596 | 314 | ;;; org-wl.el ends here |