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