Commit | Line | Data |
---|---|---|
596e5f72 | 1 | ;;; gnus-diary.el --- Wrapper around the NNDiary Gnus back end |
23f87bed | 2 | |
08a1e8ad | 3 | ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, |
e3fe4da0 | 4 | ;; 2006, 2007, 2008 Free Software Foundation, Inc. |
23f87bed MB |
5 | |
6 | ;; Author: Didier Verna <didier@xemacs.org> | |
7 | ;; Maintainer: Didier Verna <didier@xemacs.org> | |
8 | ;; Created: Tue Jul 20 10:42:55 1999 | |
9 | ;; Keywords: calendar mail news | |
10 | ||
11 | ;; This file is part of GNU Emacs. | |
12 | ||
13 | ;; GNU Emacs is free software; you can redistribute it and/or modify | |
14 | ;; it under the terms of the GNU General Public License as published | |
e757c6bd GM |
15 | ;; by the Free Software Foundation; either version 3, or (at your option) |
16 | ;; any later version. | |
23f87bed MB |
17 | |
18 | ;; GNU Emacs is distributed in the hope that it will be useful, but | |
19 | ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
20 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
21 | ;; General Public License for more details. | |
22 | ||
23 | ;; You should have received a copy of the GNU General Public License | |
e757c6bd GM |
24 | ;; along with GNU Emacs; see the file COPYING. If not, write to the |
25 | ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, | |
26 | ;; Boston, MA 02110-1301, USA. | |
23f87bed MB |
27 | |
28 | ||
29 | ;;; Commentary: | |
30 | ||
31 | ;; Contents management by FCM version 0.1. | |
32 | ||
33 | ;; Description: | |
34 | ;; =========== | |
35 | ||
596e5f72 RS |
36 | ;; gnus-diary is a utility toolkit used on top of the nndiary back end. It is |
37 | ;; now fully documented in the Gnus manual. | |
23f87bed MB |
38 | |
39 | ||
40 | ;; Bugs / Todo: | |
41 | ;; =========== | |
42 | ||
43 | ||
44 | ;;; Code: | |
45 | ||
46 | (require 'nndiary) | |
47 | (require 'message) | |
48 | (require 'gnus-art) | |
49 | ||
50 | (defgroup gnus-diary nil | |
596e5f72 | 51 | "Utilities on top of the nndiary back end for Gnus." |
d0859c9a MB |
52 | :version "22.1" |
53 | :group 'gnus) | |
23f87bed MB |
54 | |
55 | (defcustom gnus-diary-summary-line-format "%U%R%z %uD: %(%s%) (%ud)\n" | |
56 | "*Summary line format for nndiary groups." | |
57 | :type 'string | |
58 | :group 'gnus-diary | |
59 | :group 'gnus-summary-format) | |
60 | ||
61 | (defcustom gnus-diary-time-format "%a, %b %e %y, %H:%M" | |
bf8e97ae | 62 | "*Time format to display appointments in nndiary summary buffers. |
23f87bed MB |
63 | Please refer to `format-time-string' for information on possible values." |
64 | :type 'string | |
65 | :group 'gnus-diary) | |
66 | ||
67 | (defcustom gnus-diary-delay-format-function 'gnus-diary-delay-format-english | |
68 | "*Function called to format a diary delay string. | |
a4448225 | 69 | It is passed two arguments. The first one is non-nil if the delay is in |
23f87bed MB |
70 | the past. The second one is of the form ((NUM . UNIT) ...) where NUM is |
71 | an integer and UNIT is one of 'year 'month 'week 'day 'hour or 'minute. | |
72 | It should return strings like \"In 2 months, 3 weeks\", \"3 hours, | |
73 | 1 minute ago\" and so on. | |
74 | ||
75 | There are currently two built-in format functions: | |
76 | `gnus-diary-delay-format-english' (the default) | |
77 | `gnus-diary-delay-format-french'" | |
78 | :type '(choice (const :tag "english" gnus-diary-delay-format-english) | |
79 | (const :tag "french" gnus-diary-delay-format-french) | |
80 | (symbol :tag "other")) | |
81 | :group 'gnus-diary) | |
82 | ||
83 | (defconst gnus-diary-version nndiary-version | |
596e5f72 | 84 | "Current Diary back end version.") |
23f87bed MB |
85 | |
86 | ||
87 | ;; Compatibility functions ================================================== | |
88 | ||
89 | (eval-and-compile | |
90 | (if (fboundp 'kill-entire-line) | |
91 | (defalias 'gnus-diary-kill-entire-line 'kill-entire-line) | |
92 | (defun gnus-diary-kill-entire-line () | |
93 | (beginning-of-line) | |
94 | (let ((kill-whole-line t)) | |
95 | (kill-line))))) | |
96 | ||
97 | ||
98 | ;; Summary line format ====================================================== | |
99 | ||
100 | (defun gnus-diary-delay-format-french (past delay) | |
101 | (if (null delay) | |
102 | "maintenant!" | |
103 | ;; Keep only a precision of two degrees | |
104 | (and (> (length delay) 1) (setcdr (cdr delay) nil)) | |
105 | (concat (if past "il y a " "dans ") | |
106 | (let ((str "") | |
107 | del) | |
108 | (while (setq del (pop delay)) | |
109 | (setq str (concat str | |
110 | (int-to-string (car del)) " " | |
111 | (cond ((eq (cdr del) 'year) | |
112 | "an") | |
113 | ((eq (cdr del) 'month) | |
114 | "mois") | |
115 | ((eq (cdr del) 'week) | |
116 | "semaine") | |
117 | ((eq (cdr del) 'day) | |
118 | "jour") | |
119 | ((eq (cdr del) 'hour) | |
120 | "heure") | |
121 | ((eq (cdr del) 'minute) | |
122 | "minute")) | |
123 | (unless (or (eq (cdr del) 'month) | |
124 | (= (car del) 1)) | |
125 | "s") | |
126 | (if delay ", ")))) | |
127 | str)))) | |
128 | ||
129 | ||
130 | (defun gnus-diary-delay-format-english (past delay) | |
131 | (if (null delay) | |
132 | "now!" | |
133 | ;; Keep only a precision of two degrees | |
134 | (and (> (length delay) 1) (setcdr (cdr delay) nil)) | |
135 | (concat (unless past "in ") | |
136 | (let ((str "") | |
137 | del) | |
138 | (while (setq del (pop delay)) | |
139 | (setq str (concat str | |
140 | (int-to-string (car del)) " " | |
141 | (symbol-name (cdr del)) | |
142 | (and (> (car del) 1) "s") | |
143 | (if delay ", ")))) | |
144 | str) | |
145 | (and past " ago")))) | |
146 | ||
147 | ||
148 | (defun gnus-diary-header-schedule (headers) | |
149 | ;; Same as `nndiary-schedule', but given a set of headers HEADERS | |
150 | (mapcar | |
151 | (lambda (elt) | |
152 | (let ((head (cdr (assoc (intern (format "X-Diary-%s" (car elt))) | |
153 | headers)))) | |
154 | (when head | |
c1d7d285 | 155 | (nndiary-parse-schedule-value head (cadr elt) (car (cddr elt)))))) |
23f87bed MB |
156 | nndiary-headers)) |
157 | ||
158 | ;; #### NOTE: Gnus sometimes gives me a HEADER not corresponding to any | |
159 | ;; message, with all fields set to nil here. I don't know what it is for, and | |
160 | ;; I just ignore it. | |
827dc73d | 161 | ;;;###autoload |
23f87bed MB |
162 | (defun gnus-user-format-function-d (header) |
163 | ;; Returns an aproximative delay string for the next occurence of this | |
164 | ;; message. The delay is given only in the first non zero unit. | |
165 | ;; Code partly stolen from article-make-date-line | |
166 | (let* ((extras (mail-header-extra header)) | |
167 | (sched (gnus-diary-header-schedule extras)) | |
168 | (occur (nndiary-next-occurence sched (current-time))) | |
169 | (now (current-time)) | |
170 | (real-time (subtract-time occur now))) | |
171 | (if (null real-time) | |
172 | "?????" | |
173 | (let* ((sec (+ (* (float (car real-time)) 65536) (cadr real-time))) | |
174 | (past (< sec 0)) | |
175 | delay) | |
176 | (and past (setq sec (- sec))) | |
177 | (unless (zerop sec) | |
178 | ;; This is a bit convoluted, but basically we go through the time | |
179 | ;; units for years, weeks, etc, and divide things to see whether | |
180 | ;; that results in positive answers. | |
181 | (let ((units `((year . ,(* 365.25 24 3600)) | |
182 | (month . ,(* 31 24 3600)) | |
183 | (week . ,(* 7 24 3600)) | |
184 | (day . ,(* 24 3600)) | |
185 | (hour . 3600) | |
186 | (minute . 60))) | |
187 | unit num) | |
188 | (while (setq unit (pop units)) | |
189 | (unless (zerop (setq num (ffloor (/ sec (cdr unit))))) | |
190 | (setq delay (append delay `((,(floor num) . ,(car unit)))))) | |
191 | (setq sec (- sec (* num (cdr unit))))))) | |
192 | (funcall gnus-diary-delay-format-function past delay))) | |
193 | )) | |
194 | ||
195 | ;; #### NOTE: Gnus sometimes gives me a HEADER not corresponding to any | |
196 | ;; message, with all fields set to nil here. I don't know what it is for, and | |
197 | ;; I just ignore it. | |
827dc73d | 198 | ;;;###autoload |
23f87bed MB |
199 | (defun gnus-user-format-function-D (header) |
200 | ;; Returns a formatted time string for the next occurence of this message. | |
201 | (let* ((extras (mail-header-extra header)) | |
202 | (sched (gnus-diary-header-schedule extras)) | |
203 | (occur (nndiary-next-occurence sched (current-time)))) | |
204 | (format-time-string gnus-diary-time-format occur))) | |
205 | ||
206 | ||
207 | ;; Article sorting functions ================================================ | |
208 | ||
209 | (defun gnus-article-sort-by-schedule (h1 h2) | |
210 | (let* ((now (current-time)) | |
211 | (e1 (mail-header-extra h1)) | |
212 | (e2 (mail-header-extra h2)) | |
213 | (s1 (gnus-diary-header-schedule e1)) | |
214 | (s2 (gnus-diary-header-schedule e2)) | |
215 | (o1 (nndiary-next-occurence s1 now)) | |
216 | (o2 (nndiary-next-occurence s2 now))) | |
217 | (if (and (= (car o1) (car o2)) (= (cadr o1) (cadr o2))) | |
218 | (< (mail-header-number h1) (mail-header-number h2)) | |
219 | (time-less-p o1 o2)))) | |
220 | ||
221 | ||
222 | (defun gnus-thread-sort-by-schedule (h1 h2) | |
223 | (gnus-article-sort-by-schedule (gnus-thread-header h1) | |
224 | (gnus-thread-header h2))) | |
225 | ||
226 | (defun gnus-summary-sort-by-schedule (&optional reverse) | |
bf8e97ae | 227 | "Sort nndiary summary buffers by schedule of appointments. |
23f87bed MB |
228 | Optional prefix (or REVERSE argument) means sort in reverse order." |
229 | (interactive "P") | |
230 | (gnus-summary-sort 'schedule reverse)) | |
231 | ||
232 | (defvar gnus-summary-misc-menu) ;; Avoid byte compiler warning. | |
233 | (add-hook 'gnus-summary-menu-hook | |
234 | (lambda () | |
235 | (easy-menu-add-item gnus-summary-misc-menu | |
236 | '("Sort") | |
237 | ["Sort by schedule" | |
238 | gnus-summary-sort-by-schedule | |
239 | (eq (car (gnus-find-method-for-group | |
240 | gnus-newsgroup-name)) | |
241 | 'nndiary)] | |
242 | "Sort by number"))) | |
243 | ||
244 | ||
245 | ||
246 | ;; Group parameters autosetting ============================================= | |
247 | ||
248 | (defun gnus-diary-update-group-parameters (group) | |
249 | ;; Ensure that nndiary groups have convenient group parameters: | |
250 | ;; - a posting style containing X-Diary headers | |
251 | ;; - a nice summary line format | |
252 | ;; - NNDiary specific sorting by schedule functions | |
253 | ;; In general, try not to mess with what the user might have modified. | |
01c52d31 MB |
254 | |
255 | ;; Posting style: | |
256 | (let ((posting-style (gnus-group-get-parameter group 'posting-style t)) | |
257 | (headers nndiary-headers) | |
258 | header) | |
259 | (while headers | |
260 | (setq header (format "X-Diary-%s" (caar headers)) | |
261 | headers (cdr headers)) | |
262 | (unless (assoc header posting-style) | |
263 | (setq posting-style (append posting-style (list (list header "*")))))) | |
264 | (gnus-group-set-parameter group 'posting-style posting-style)) | |
265 | ;; Summary line format: | |
266 | (unless (gnus-group-get-parameter group 'gnus-summary-line-format t) | |
267 | (gnus-group-set-parameter group 'gnus-summary-line-format | |
268 | `(,gnus-diary-summary-line-format))) | |
269 | ;; Sorting by schedule: | |
270 | (unless (gnus-group-get-parameter group 'gnus-article-sort-functions) | |
271 | (gnus-group-set-parameter group 'gnus-article-sort-functions | |
272 | '((append gnus-article-sort-functions | |
273 | (list | |
274 | 'gnus-article-sort-by-schedule))))) | |
275 | (unless (gnus-group-get-parameter group 'gnus-thread-sort-functions) | |
276 | (gnus-group-set-parameter group 'gnus-thread-sort-functions | |
277 | '((append gnus-thread-sort-functions | |
278 | (list | |
279 | 'gnus-thread-sort-by-schedule)))))) | |
23f87bed MB |
280 | |
281 | ;; Called when a group is subscribed. This is needed because groups created | |
596e5f72 | 282 | ;; because of mail splitting are *not* created with the back end function. |
23f87bed MB |
283 | ;; Thus, `nndiary-request-create-group-hooks' is inoperative. |
284 | (defun gnus-diary-maybe-update-group-parameters (group) | |
285 | (when (eq (car (gnus-find-method-for-group group)) 'nndiary) | |
286 | (gnus-diary-update-group-parameters group))) | |
287 | ||
288 | (add-hook 'nndiary-request-create-group-hooks | |
289 | 'gnus-diary-update-group-parameters) | |
290 | ;; Now that we have `gnus-subscribe-newsgroup-hooks', this is not needed | |
291 | ;; anymore. Maybe I should remove this completely. | |
292 | (add-hook 'nndiary-request-update-info-hooks | |
293 | 'gnus-diary-update-group-parameters) | |
294 | (add-hook 'gnus-subscribe-newsgroup-hooks | |
295 | 'gnus-diary-maybe-update-group-parameters) | |
296 | ||
297 | ||
298 | ;; Diary Message Checking =================================================== | |
299 | ||
300 | (defvar gnus-diary-header-value-history nil | |
301 | ;; History variable for header value prompting | |
302 | ) | |
303 | ||
304 | (defun gnus-diary-narrow-to-headers () | |
305 | "Narrow the current buffer to the header part. | |
306 | Point is left at the beginning of the region. | |
307 | The buffer is assumed to contain a message, but the format is unknown." | |
308 | (cond ((eq major-mode 'message-mode) | |
309 | (message-narrow-to-headers)) | |
310 | (t | |
311 | (goto-char (point-min)) | |
312 | (when (search-forward "\n\n" nil t) | |
313 | (narrow-to-region (point-min) (- (point) 1)) | |
314 | (goto-char (point-min)))) | |
315 | )) | |
316 | ||
317 | (defun gnus-diary-add-header (str) | |
318 | "Add a header to the current buffer. | |
319 | The buffer is assumed to contain a message, but the format is unknown." | |
320 | (cond ((eq major-mode 'message-mode) | |
321 | (message-add-header str)) | |
322 | (t | |
323 | (save-restriction | |
324 | (gnus-diary-narrow-to-headers) | |
325 | (goto-char (point-max)) | |
326 | (if (string-match "\n$" str) | |
327 | (insert str) | |
328 | (insert str ?\n)))) | |
329 | )) | |
330 | ||
331 | (defun gnus-diary-check-message (arg) | |
332 | "Ensure that the current message is a valid for NNDiary. | |
333 | This function checks that all NNDiary required headers are present and | |
334 | valid, and prompts for values / correction otherwise. | |
335 | ||
336 | If ARG (or prefix) is non-nil, force prompting for all fields." | |
337 | (interactive "P") | |
338 | (save-excursion | |
339 | (mapcar | |
340 | (lambda (head) | |
341 | (let ((header (concat "X-Diary-" (car head))) | |
342 | (ask arg) | |
343 | value invalid) | |
344 | ;; First, try to find the header, and checks for validity: | |
345 | (save-restriction | |
346 | (gnus-diary-narrow-to-headers) | |
347 | (when (re-search-forward (concat "^" header ":") nil t) | |
348 | (unless (eq (char-after) ? ) | |
349 | (insert " ")) | |
01c52d31 | 350 | (setq value (buffer-substring (point) (point-at-eol))) |
23f87bed MB |
351 | (and (string-match "[ \t]*\\([^ \t]+\\)[ \t]*" value) |
352 | (setq value (match-string 1 value))) | |
353 | (condition-case () | |
354 | (nndiary-parse-schedule-value value | |
355 | (nth 1 head) (nth 2 head)) | |
356 | (t | |
357 | (setq invalid t))) | |
358 | ;; #### NOTE: this (along with the `gnus-diary-add-header' | |
359 | ;; function) could be rewritten in a better way, in particular | |
360 | ;; not to blindly remove an already present header and reinsert | |
361 | ;; it somewhere else afterwards. | |
362 | (when (or ask invalid) | |
363 | (gnus-diary-kill-entire-line)) | |
364 | )) | |
365 | ;; Now, loop until a valid value is provided: | |
366 | (while (or ask (not value) invalid) | |
367 | (let ((prompt (concat (and invalid | |
368 | (prog1 "(current value invalid) " | |
369 | (beep))) | |
370 | header ": "))) | |
371 | (setq value | |
372 | (if (listp (nth 1 head)) | |
373 | (completing-read prompt (cons '("*" nil) (nth 1 head)) | |
374 | nil t value | |
375 | gnus-diary-header-value-history) | |
376 | (read-string prompt value | |
377 | gnus-diary-header-value-history)))) | |
378 | (setq ask nil) | |
379 | (setq invalid nil) | |
380 | (condition-case () | |
381 | (nndiary-parse-schedule-value value | |
382 | (nth 1 head) (nth 2 head)) | |
383 | (t | |
384 | (setq invalid t)))) | |
385 | (gnus-diary-add-header (concat header ": " value)) | |
386 | )) | |
387 | nndiary-headers) | |
388 | )) | |
389 | ||
390 | (add-hook 'nndiary-request-accept-article-hooks | |
391 | (lambda () (gnus-diary-check-message nil))) | |
392 | ||
393 | (define-key message-mode-map "\C-cDc" 'gnus-diary-check-message) | |
394 | (define-key gnus-article-edit-mode-map "\C-cDc" 'gnus-diary-check-message) | |
395 | ||
396 | ||
397 | ;; The end ================================================================== | |
398 | ||
399 | (defun gnus-diary-version () | |
596e5f72 | 400 | "Current Diary back end version." |
23f87bed MB |
401 | (interactive) |
402 | (message "NNDiary version %s" nndiary-version)) | |
403 | ||
404 | (define-key message-mode-map "\C-cDv" 'gnus-diary-version) | |
405 | (define-key gnus-article-edit-mode-map "\C-cDv" 'gnus-diary-version) | |
406 | ||
407 | ||
408 | (provide 'gnus-diary) | |
409 | ||
cbee283d | 410 | ;; arch-tag: 98467e70-337e-4ddc-b92d-45d403ff1b4b |
23f87bed | 411 | ;;; gnus-diary.el ends here |