1 ;;; gnus-diary.el --- Wrapper around the NNDiary Gnus back end
3 ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005,
4 ;; 2006, 2007, 2008 Free Software Foundation, Inc.
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
11 ;; This file is part of GNU Emacs.
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 3, or (at your option)
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.
23 ;; You should have received a copy of the GNU General Public License
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.
31 ;; Contents management by FCM version 0.1.
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.
50 (defgroup gnus-diary nil
51 "Utilities on top of the nndiary back end for Gnus."
55 (defcustom gnus-diary-summary-line-format
"%U%R%z %uD: %(%s%) (%ud)\n"
56 "*Summary line format for nndiary groups."
59 :group
'gnus-summary-format
)
61 (defcustom gnus-diary-time-format
"%a, %b %e %y, %H:%M"
62 "*Time format to display appointments in nndiary summary buffers.
63 Please refer to `format-time-string' for information on possible values."
67 (defcustom gnus-diary-delay-format-function
'gnus-diary-delay-format-english
68 "*Function called to format a diary delay string.
69 It is passed two arguments. The first one is non-nil if the delay is in
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.
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"))
83 (defconst gnus-diary-version nndiary-version
84 "Current Diary back end version.")
87 ;; Compatibility functions ==================================================
90 (if (fboundp 'kill-entire-line
)
91 (defalias 'gnus-diary-kill-entire-line
'kill-entire-line
)
92 (defun gnus-diary-kill-entire-line ()
94 (let ((kill-whole-line t
))
98 ;; Summary line format ======================================================
100 (defun gnus-diary-delay-format-french (past delay
)
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 ")
108 (while (setq del
(pop delay
))
109 (setq str
(concat str
110 (int-to-string (car del
)) " "
111 (cond ((eq (cdr del
) 'year
)
113 ((eq (cdr del
) 'month
)
115 ((eq (cdr del
) 'week
)
119 ((eq (cdr del
) 'hour
)
121 ((eq (cdr del
) 'minute
)
123 (unless (or (eq (cdr del
) 'month
)
130 (defun gnus-diary-delay-format-english (past delay
)
133 ;; Keep only a precision of two degrees
134 (and (> (length delay
) 1) (setcdr (cdr delay
) nil
))
135 (concat (unless past
"in ")
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")
148 (defun gnus-diary-header-schedule (headers)
149 ;; Same as `nndiary-schedule', but given a set of headers HEADERS
152 (let ((head (cdr (assoc (intern (format "X-Diary-%s" (car elt
)))
155 (nndiary-parse-schedule-value head
(cadr elt
) (car (cddr elt
))))))
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
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)))
170 (real-time (subtract-time occur now
)))
173 (let* ((sec (+ (* (float (car real-time
)) 65536) (cadr real-time
)))
176 (and past
(setq sec
(- 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))
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
)))
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
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
)))
207 ;; Article sorting functions ================================================
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
))))
222 (defun gnus-thread-sort-by-schedule (h1 h2
)
223 (gnus-article-sort-by-schedule (gnus-thread-header h1
)
224 (gnus-thread-header h2
)))
226 (defun gnus-summary-sort-by-schedule (&optional reverse
)
227 "Sort nndiary summary buffers by schedule of appointments.
228 Optional prefix (or REVERSE argument) means sort in reverse order."
230 (gnus-summary-sort 'schedule reverse
))
232 (defvar gnus-summary-misc-menu
) ;; Avoid byte compiler warning.
233 (add-hook 'gnus-summary-menu-hook
235 (easy-menu-add-item gnus-summary-misc-menu
238 gnus-summary-sort-by-schedule
239 (eq (car (gnus-find-method-for-group
240 gnus-newsgroup-name
))
246 ;; Group parameters autosetting =============================================
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.
256 (let ((posting-style (gnus-group-get-parameter group
'posting-style t
))
257 (headers nndiary-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
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
279 'gnus-thread-sort-by-schedule
))))))
281 ;; Called when a group is subscribed. This is needed because groups created
282 ;; because of mail splitting are *not* created with the back end function.
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
)))
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
)
298 ;; Diary Message Checking ===================================================
300 (defvar gnus-diary-header-value-history nil
301 ;; History variable for header value prompting
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))
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))))
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
))
324 (gnus-diary-narrow-to-headers)
325 (goto-char (point-max))
326 (if (string-match "\n$" str
)
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.
336 If ARG (or prefix) is non-nil, force prompting for all fields."
341 (let ((header (concat "X-Diary-" (car head
)))
344 ;; First, try to find the header, and checks for validity:
346 (gnus-diary-narrow-to-headers)
347 (when (re-search-forward (concat "^" header
":") nil t
)
348 (unless (eq (char-after) ?
)
350 (setq value
(buffer-substring (point) (point-at-eol)))
351 (and (string-match "[ \t]*\\([^ \t]+\\)[ \t]*" value
)
352 (setq value
(match-string 1 value
)))
354 (nndiary-parse-schedule-value value
355 (nth 1 head
) (nth 2 head
))
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))
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) "
372 (if (listp (nth 1 head
))
373 (completing-read prompt
(cons '("*" nil
) (nth 1 head
))
375 gnus-diary-header-value-history
)
376 (read-string prompt value
377 gnus-diary-header-value-history
))))
381 (nndiary-parse-schedule-value value
382 (nth 1 head
) (nth 2 head
))
385 (gnus-diary-add-header (concat header
": " value
))
390 (add-hook 'nndiary-request-accept-article-hooks
391 (lambda () (gnus-diary-check-message nil
)))
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
)
397 ;; The end ==================================================================
399 (defun gnus-diary-version ()
400 "Current Diary back end version."
402 (message "NNDiary version %s" nndiary-version
))
404 (define-key message-mode-map
"\C-cDv" 'gnus-diary-version
)
405 (define-key gnus-article-edit-mode-map
"\C-cDv" 'gnus-diary-version
)
408 (provide 'gnus-diary
)
410 ;; arch-tag: 98467e70-337e-4ddc-b92d-45d403ff1b4b
411 ;;; gnus-diary.el ends here