Mercurial > emacs
comparison lisp/gnus/gnus-diary.el @ 82951:0fde48feb604
Import Gnus 5.10 from the v5_10 branch of the Gnus repository.
author | Andreas Schwab <schwab@suse.de> |
---|---|
date | Thu, 22 Jul 2004 16:45:51 +0000 |
parents | |
children | cee5a9d8ee71 |
comparison
equal
deleted
inserted
replaced
56503:8bbd2323fbf2 | 82951:0fde48feb604 |
---|---|
1 ;;; gnus-diary.el --- Wrapper around the NNDiary Gnus backend | |
2 | |
3 ;; Copyright (c) 2001, 2002, 2003 Free Software Foundation, Inc. | |
4 ;; Copyright (C) 1999, 2000, 2001 Didier Verna. | |
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 | |
15 ;; by the Free Software Foundation; either version 2 of the License, | |
16 ;; or (at your option) any later version. | |
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 | |
24 ;; along with this program; if not, write to the Free Software | |
25 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. | |
26 | |
27 | |
28 ;;; Commentary: | |
29 | |
30 ;; Contents management by FCM version 0.1. | |
31 | |
32 ;; Description: | |
33 ;; =========== | |
34 | |
35 ;; Gnus-Diary is a wrapper around the NNDiary Gnus backend. It is here to | |
36 ;; make your nndiary-user life easier in different ways. So, you don't have | |
37 ;; to use it if you don't want to. But, really, you should. | |
38 | |
39 ;; Gnus-Diary offers the following features on top of the NNDiary backend: | |
40 | |
41 ;; - A nice summary line format: | |
42 ;; Displaying diary messages in standard summary line format (usually | |
43 ;; something like "<From Joe>: <Subject>") is pretty useless. Most of the | |
44 ;; time, you're the one who wrote the message, and you mostly want to see | |
45 ;; the event's date. Gnus-Diary offers you a nice summary line format | |
46 ;; which will do this. By default, a summary line will appear like this: | |
47 ;; | |
48 ;; <Event Date>: <Subject> <Remaining time> | |
49 ;; | |
50 ;; for example, here's how Joe's birthday is displayed in my | |
51 ;; "nndiary:birhdays" summary buffer (the message is expirable, but will | |
52 ;; never be deleted, as it specifies a regular event): | |
53 ;; | |
54 ;; E Sat, Sep 22 01, 12:00: Joe's birthday (in 6 months, 1 week) | |
55 | |
56 ;; - More article sorting functions: | |
57 ;; Gnus-Diary adds a new sorting function called | |
58 ;; `gnus-summary-sort-by-schedule'. This function lets you organize your | |
59 ;; diary summary buffers from the closest event to the farthest one. | |
60 | |
61 ;; - Automatic generation of diary group parameters: | |
62 ;; When you create a new diary group, or visit one, Gnus-Diary checks your | |
63 ;; group parameters, and if needed, sets the summary line format to the | |
64 ;; diary-specific value, adds the diary-specific sorting functions, and | |
65 ;; also adds the different `X-Diary-*' headers to the group's | |
66 ;; posting-style. It is then easier to send a diary message, because if | |
67 ;; you use `C-u a' or `C-u m' on a diary group to prepare a message, these | |
68 ;; headers will be inserted automatically (but not filled with proper | |
69 ;; values yet). | |
70 | |
71 ;; - An interactive mail-to-diary convertion function: | |
72 ;; The function `gnus-diary-check-message' ensures that the current message | |
73 ;; contains all the required diary headers, and prompts you for values / | |
74 ;; correction if needed. This function is hooked in the nndiary backend so | |
75 ;; that moving an article to an nndiary group will trigger it | |
76 ;; automatically. It is also bound to `C-c D c' in message-mode and | |
77 ;; article-edit-mode in order to ease the process of converting a usual | |
78 ;; mail to a diary one. This function takes a prefix argument which will | |
79 ;; force prompting of all diary headers, regardless of their | |
80 ;; presence/validity. That way, you can very easily reschedule a diary | |
81 ;; message for instance. | |
82 | |
83 | |
84 ;; Usage: | |
85 ;; ===== | |
86 | |
87 ;; 0/ Don't use any `gnus-user-format-function-[d|D]'. Gnus-Diary provides | |
88 ;; both of these (sorry if you used them before). | |
89 ;; 1/ Add '(require 'gnus-diary) to your gnusrc file. | |
90 ;; 2/ Customize your gnus-diary options to suit your needs. | |
91 | |
92 | |
93 | |
94 ;; Bugs / Todo: | |
95 ;; =========== | |
96 | |
97 | |
98 ;;; Code: | |
99 | |
100 (require 'nndiary) | |
101 (require 'message) | |
102 (require 'gnus-art) | |
103 | |
104 (defgroup gnus-diary nil | |
105 "Utilities on top of the nndiary backend for Gnus.") | |
106 | |
107 (defcustom gnus-diary-summary-line-format "%U%R%z %uD: %(%s%) (%ud)\n" | |
108 "*Summary line format for nndiary groups." | |
109 :type 'string | |
110 :group 'gnus-diary | |
111 :group 'gnus-summary-format) | |
112 | |
113 (defcustom gnus-diary-time-format "%a, %b %e %y, %H:%M" | |
114 "*Time format to display appointements in nndiary summary buffers. | |
115 Please refer to `format-time-string' for information on possible values." | |
116 :type 'string | |
117 :group 'gnus-diary) | |
118 | |
119 (defcustom gnus-diary-delay-format-function 'gnus-diary-delay-format-english | |
120 "*Function called to format a diary delay string. | |
121 It is passed two arguments. The first one is non nil if the delay is in | |
122 the past. The second one is of the form ((NUM . UNIT) ...) where NUM is | |
123 an integer and UNIT is one of 'year 'month 'week 'day 'hour or 'minute. | |
124 It should return strings like \"In 2 months, 3 weeks\", \"3 hours, | |
125 1 minute ago\" and so on. | |
126 | |
127 There are currently two built-in format functions: | |
128 `gnus-diary-delay-format-english' (the default) | |
129 `gnus-diary-delay-format-french'" | |
130 :type '(choice (const :tag "english" gnus-diary-delay-format-english) | |
131 (const :tag "french" gnus-diary-delay-format-french) | |
132 (symbol :tag "other")) | |
133 :group 'gnus-diary) | |
134 | |
135 (defconst gnus-diary-version nndiary-version | |
136 "Current Diary backend version.") | |
137 | |
138 | |
139 ;; Compatibility functions ================================================== | |
140 | |
141 (eval-and-compile | |
142 (if (fboundp 'kill-entire-line) | |
143 (defalias 'gnus-diary-kill-entire-line 'kill-entire-line) | |
144 (defun gnus-diary-kill-entire-line () | |
145 (beginning-of-line) | |
146 (let ((kill-whole-line t)) | |
147 (kill-line))))) | |
148 | |
149 | |
150 ;; Summary line format ====================================================== | |
151 | |
152 (defun gnus-diary-delay-format-french (past delay) | |
153 (if (null delay) | |
154 "maintenant!" | |
155 ;; Keep only a precision of two degrees | |
156 (and (> (length delay) 1) (setcdr (cdr delay) nil)) | |
157 (concat (if past "il y a " "dans ") | |
158 (let ((str "") | |
159 del) | |
160 (while (setq del (pop delay)) | |
161 (setq str (concat str | |
162 (int-to-string (car del)) " " | |
163 (cond ((eq (cdr del) 'year) | |
164 "an") | |
165 ((eq (cdr del) 'month) | |
166 "mois") | |
167 ((eq (cdr del) 'week) | |
168 "semaine") | |
169 ((eq (cdr del) 'day) | |
170 "jour") | |
171 ((eq (cdr del) 'hour) | |
172 "heure") | |
173 ((eq (cdr del) 'minute) | |
174 "minute")) | |
175 (unless (or (eq (cdr del) 'month) | |
176 (= (car del) 1)) | |
177 "s") | |
178 (if delay ", ")))) | |
179 str)))) | |
180 | |
181 | |
182 (defun gnus-diary-delay-format-english (past delay) | |
183 (if (null delay) | |
184 "now!" | |
185 ;; Keep only a precision of two degrees | |
186 (and (> (length delay) 1) (setcdr (cdr delay) nil)) | |
187 (concat (unless past "in ") | |
188 (let ((str "") | |
189 del) | |
190 (while (setq del (pop delay)) | |
191 (setq str (concat str | |
192 (int-to-string (car del)) " " | |
193 (symbol-name (cdr del)) | |
194 (and (> (car del) 1) "s") | |
195 (if delay ", ")))) | |
196 str) | |
197 (and past " ago")))) | |
198 | |
199 | |
200 (defun gnus-diary-header-schedule (headers) | |
201 ;; Same as `nndiary-schedule', but given a set of headers HEADERS | |
202 (mapcar | |
203 (lambda (elt) | |
204 (let ((head (cdr (assoc (intern (format "X-Diary-%s" (car elt))) | |
205 headers)))) | |
206 (when head | |
207 (nndiary-parse-schedule-value head (cadr elt) (caddr elt))))) | |
208 nndiary-headers)) | |
209 | |
210 ;; #### NOTE: Gnus sometimes gives me a HEADER not corresponding to any | |
211 ;; message, with all fields set to nil here. I don't know what it is for, and | |
212 ;; I just ignore it. | |
213 (defun gnus-user-format-function-d (header) | |
214 ;; Returns an aproximative delay string for the next occurence of this | |
215 ;; message. The delay is given only in the first non zero unit. | |
216 ;; Code partly stolen from article-make-date-line | |
217 (let* ((extras (mail-header-extra header)) | |
218 (sched (gnus-diary-header-schedule extras)) | |
219 (occur (nndiary-next-occurence sched (current-time))) | |
220 (now (current-time)) | |
221 (real-time (subtract-time occur now))) | |
222 (if (null real-time) | |
223 "?????" | |
224 (let* ((sec (+ (* (float (car real-time)) 65536) (cadr real-time))) | |
225 (past (< sec 0)) | |
226 delay) | |
227 (and past (setq sec (- sec))) | |
228 (unless (zerop sec) | |
229 ;; This is a bit convoluted, but basically we go through the time | |
230 ;; units for years, weeks, etc, and divide things to see whether | |
231 ;; that results in positive answers. | |
232 (let ((units `((year . ,(* 365.25 24 3600)) | |
233 (month . ,(* 31 24 3600)) | |
234 (week . ,(* 7 24 3600)) | |
235 (day . ,(* 24 3600)) | |
236 (hour . 3600) | |
237 (minute . 60))) | |
238 unit num) | |
239 (while (setq unit (pop units)) | |
240 (unless (zerop (setq num (ffloor (/ sec (cdr unit))))) | |
241 (setq delay (append delay `((,(floor num) . ,(car unit)))))) | |
242 (setq sec (- sec (* num (cdr unit))))))) | |
243 (funcall gnus-diary-delay-format-function past delay))) | |
244 )) | |
245 | |
246 ;; #### NOTE: Gnus sometimes gives me a HEADER not corresponding to any | |
247 ;; message, with all fields set to nil here. I don't know what it is for, and | |
248 ;; I just ignore it. | |
249 (defun gnus-user-format-function-D (header) | |
250 ;; Returns a formatted time string for the next occurence of this message. | |
251 (let* ((extras (mail-header-extra header)) | |
252 (sched (gnus-diary-header-schedule extras)) | |
253 (occur (nndiary-next-occurence sched (current-time)))) | |
254 (format-time-string gnus-diary-time-format occur))) | |
255 | |
256 | |
257 ;; Article sorting functions ================================================ | |
258 | |
259 (defun gnus-article-sort-by-schedule (h1 h2) | |
260 (let* ((now (current-time)) | |
261 (e1 (mail-header-extra h1)) | |
262 (e2 (mail-header-extra h2)) | |
263 (s1 (gnus-diary-header-schedule e1)) | |
264 (s2 (gnus-diary-header-schedule e2)) | |
265 (o1 (nndiary-next-occurence s1 now)) | |
266 (o2 (nndiary-next-occurence s2 now))) | |
267 (if (and (= (car o1) (car o2)) (= (cadr o1) (cadr o2))) | |
268 (< (mail-header-number h1) (mail-header-number h2)) | |
269 (time-less-p o1 o2)))) | |
270 | |
271 | |
272 (defun gnus-thread-sort-by-schedule (h1 h2) | |
273 (gnus-article-sort-by-schedule (gnus-thread-header h1) | |
274 (gnus-thread-header h2))) | |
275 | |
276 (defun gnus-summary-sort-by-schedule (&optional reverse) | |
277 "Sort nndiary summary buffers by schedule of appointements. | |
278 Optional prefix (or REVERSE argument) means sort in reverse order." | |
279 (interactive "P") | |
280 (gnus-summary-sort 'schedule reverse)) | |
281 | |
282 (defvar gnus-summary-misc-menu) ;; Avoid byte compiler warning. | |
283 (add-hook 'gnus-summary-menu-hook | |
284 (lambda () | |
285 (easy-menu-add-item gnus-summary-misc-menu | |
286 '("Sort") | |
287 ["Sort by schedule" | |
288 gnus-summary-sort-by-schedule | |
289 (eq (car (gnus-find-method-for-group | |
290 gnus-newsgroup-name)) | |
291 'nndiary)] | |
292 "Sort by number"))) | |
293 | |
294 | |
295 | |
296 ;; Group parameters autosetting ============================================= | |
297 | |
298 (defun gnus-diary-update-group-parameters (group) | |
299 ;; Ensure that nndiary groups have convenient group parameters: | |
300 ;; - a posting style containing X-Diary headers | |
301 ;; - a nice summary line format | |
302 ;; - NNDiary specific sorting by schedule functions | |
303 ;; In general, try not to mess with what the user might have modified. | |
304 (let ((posting-style (gnus-group-get-parameter group 'posting-style t))) | |
305 ;; Posting style: | |
306 (mapcar (lambda (elt) | |
307 (let ((header (format "X-Diary-%s" (car elt)))) | |
308 (unless (assoc header posting-style) | |
309 (setq posting-style (append posting-style | |
310 `((,header "*"))))) | |
311 )) | |
312 nndiary-headers) | |
313 (gnus-group-set-parameter group 'posting-style posting-style) | |
314 ;; Summary line format: | |
315 (unless (gnus-group-get-parameter group 'gnus-summary-line-format t) | |
316 (gnus-group-set-parameter group 'gnus-summary-line-format | |
317 `(,gnus-diary-summary-line-format))) | |
318 ;; Sorting by schedule: | |
319 (unless (gnus-group-get-parameter group 'gnus-article-sort-functions) | |
320 (gnus-group-set-parameter group 'gnus-article-sort-functions | |
321 '((append gnus-article-sort-functions | |
322 (list | |
323 'gnus-article-sort-by-schedule))))) | |
324 (unless (gnus-group-get-parameter group 'gnus-thread-sort-functions) | |
325 (gnus-group-set-parameter group 'gnus-thread-sort-functions | |
326 '((append gnus-thread-sort-functions | |
327 (list | |
328 'gnus-thread-sort-by-schedule))))) | |
329 )) | |
330 | |
331 ;; Called when a group is subscribed. This is needed because groups created | |
332 ;; because of mail splitting are *not* created with the backend function. | |
333 ;; Thus, `nndiary-request-create-group-hooks' is inoperative. | |
334 (defun gnus-diary-maybe-update-group-parameters (group) | |
335 (when (eq (car (gnus-find-method-for-group group)) 'nndiary) | |
336 (gnus-diary-update-group-parameters group))) | |
337 | |
338 (add-hook 'nndiary-request-create-group-hooks | |
339 'gnus-diary-update-group-parameters) | |
340 ;; Now that we have `gnus-subscribe-newsgroup-hooks', this is not needed | |
341 ;; anymore. Maybe I should remove this completely. | |
342 (add-hook 'nndiary-request-update-info-hooks | |
343 'gnus-diary-update-group-parameters) | |
344 (add-hook 'gnus-subscribe-newsgroup-hooks | |
345 'gnus-diary-maybe-update-group-parameters) | |
346 | |
347 | |
348 ;; Diary Message Checking =================================================== | |
349 | |
350 (defvar gnus-diary-header-value-history nil | |
351 ;; History variable for header value prompting | |
352 ) | |
353 | |
354 (defun gnus-diary-narrow-to-headers () | |
355 "Narrow the current buffer to the header part. | |
356 Point is left at the beginning of the region. | |
357 The buffer is assumed to contain a message, but the format is unknown." | |
358 (cond ((eq major-mode 'message-mode) | |
359 (message-narrow-to-headers)) | |
360 (t | |
361 (goto-char (point-min)) | |
362 (when (search-forward "\n\n" nil t) | |
363 (narrow-to-region (point-min) (- (point) 1)) | |
364 (goto-char (point-min)))) | |
365 )) | |
366 | |
367 (defun gnus-diary-add-header (str) | |
368 "Add a header to the current buffer. | |
369 The buffer is assumed to contain a message, but the format is unknown." | |
370 (cond ((eq major-mode 'message-mode) | |
371 (message-add-header str)) | |
372 (t | |
373 (save-restriction | |
374 (gnus-diary-narrow-to-headers) | |
375 (goto-char (point-max)) | |
376 (if (string-match "\n$" str) | |
377 (insert str) | |
378 (insert str ?\n)))) | |
379 )) | |
380 | |
381 (defun gnus-diary-check-message (arg) | |
382 "Ensure that the current message is a valid for NNDiary. | |
383 This function checks that all NNDiary required headers are present and | |
384 valid, and prompts for values / correction otherwise. | |
385 | |
386 If ARG (or prefix) is non-nil, force prompting for all fields." | |
387 (interactive "P") | |
388 (save-excursion | |
389 (mapcar | |
390 (lambda (head) | |
391 (let ((header (concat "X-Diary-" (car head))) | |
392 (ask arg) | |
393 value invalid) | |
394 ;; First, try to find the header, and checks for validity: | |
395 (save-restriction | |
396 (gnus-diary-narrow-to-headers) | |
397 (when (re-search-forward (concat "^" header ":") nil t) | |
398 (unless (eq (char-after) ? ) | |
399 (insert " ")) | |
400 (setq value (buffer-substring (point) (gnus-point-at-eol))) | |
401 (and (string-match "[ \t]*\\([^ \t]+\\)[ \t]*" value) | |
402 (setq value (match-string 1 value))) | |
403 (condition-case () | |
404 (nndiary-parse-schedule-value value | |
405 (nth 1 head) (nth 2 head)) | |
406 (t | |
407 (setq invalid t))) | |
408 ;; #### NOTE: this (along with the `gnus-diary-add-header' | |
409 ;; function) could be rewritten in a better way, in particular | |
410 ;; not to blindly remove an already present header and reinsert | |
411 ;; it somewhere else afterwards. | |
412 (when (or ask invalid) | |
413 (gnus-diary-kill-entire-line)) | |
414 )) | |
415 ;; Now, loop until a valid value is provided: | |
416 (while (or ask (not value) invalid) | |
417 (let ((prompt (concat (and invalid | |
418 (prog1 "(current value invalid) " | |
419 (beep))) | |
420 header ": "))) | |
421 (setq value | |
422 (if (listp (nth 1 head)) | |
423 (completing-read prompt (cons '("*" nil) (nth 1 head)) | |
424 nil t value | |
425 gnus-diary-header-value-history) | |
426 (read-string prompt value | |
427 gnus-diary-header-value-history)))) | |
428 (setq ask nil) | |
429 (setq invalid nil) | |
430 (condition-case () | |
431 (nndiary-parse-schedule-value value | |
432 (nth 1 head) (nth 2 head)) | |
433 (t | |
434 (setq invalid t)))) | |
435 (gnus-diary-add-header (concat header ": " value)) | |
436 )) | |
437 nndiary-headers) | |
438 )) | |
439 | |
440 (add-hook 'nndiary-request-accept-article-hooks | |
441 (lambda () (gnus-diary-check-message nil))) | |
442 | |
443 (define-key message-mode-map "\C-cDc" 'gnus-diary-check-message) | |
444 (define-key gnus-article-edit-mode-map "\C-cDc" 'gnus-diary-check-message) | |
445 | |
446 | |
447 ;; The end ================================================================== | |
448 | |
449 (defun gnus-diary-version () | |
450 "Current Diary backend version." | |
451 (interactive) | |
452 (message "NNDiary version %s" nndiary-version)) | |
453 | |
454 (define-key message-mode-map "\C-cDv" 'gnus-diary-version) | |
455 (define-key gnus-article-edit-mode-map "\C-cDv" 'gnus-diary-version) | |
456 | |
457 | |
458 (provide 'gnus-diary) | |
459 | |
460 ;;; arch-tag: 98467e70-337e-4ddc-b92d-45d403ff1b4b | |
461 ;;; gnus-diary.el ends here |