1 ;;; gnus-diary.el --- Wrapper around the NNDiary Gnus back end
3 ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005,
4 ;; 2006, 2007 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