1 ;;; gnus-diary.el --- Wrapper around the NNDiary Gnus back end
3 ;; Copyright (C) 1999-2016 Free Software Foundation, Inc.
5 ;; Author: Didier Verna <didier@xemacs.org>
6 ;; Maintainer: Didier Verna <didier@xemacs.org>
7 ;; Created: Tue Jul 20 10:42:55 1999
8 ;; Keywords: calendar mail news
10 ;; This file is part of GNU Emacs.
12 ;; GNU Emacs is free software: you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation, either version 3 of the License, or
15 ;; (at your option) any later version.
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.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
28 ;; Contents management by FCM version 0.1.
33 ;; gnus-diary is a utility toolkit used on top of the nndiary back end. It is
34 ;; now fully documented in the Gnus manual.
47 (defgroup gnus-diary nil
48 "Utilities on top of the nndiary back end for Gnus."
52 (defcustom gnus-diary-summary-line-format "%U%R%z %uD: %(%s%) (%ud)\n"
53 "*Summary line format for nndiary groups."
56 :group 'gnus-summary-format)
58 (defcustom gnus-diary-time-format "%a, %b %e %y, %H:%M"
59 "*Time format to display appointments in nndiary summary buffers.
60 Please refer to `format-time-string' for information on possible values."
64 (defcustom gnus-diary-delay-format-function 'gnus-diary-delay-format-english
65 "*Function called to format a diary delay string.
66 It is passed two arguments. The first one is non-nil if the delay is in
67 the past. The second one is of the form ((NUM . UNIT) ...) where NUM is
68 an integer and UNIT is one of 'year 'month 'week 'day 'hour or 'minute.
69 It should return strings like \"In 2 months, 3 weeks\", \"3 hours,
70 1 minute ago\" and so on.
72 There are currently two built-in format functions:
73 `gnus-diary-delay-format-english' (the default)
74 `gnus-diary-delay-format-french'"
75 :type '(choice (const :tag "english" gnus-diary-delay-format-english)
76 (const :tag "french" gnus-diary-delay-format-french)
77 (symbol :tag "other"))
80 (defconst gnus-diary-version nndiary-version
81 "Current Diary back end version.")
84 ;; Compatibility functions ==================================================
87 (if (fboundp 'kill-entire-line)
88 (defalias 'gnus-diary-kill-entire-line 'kill-entire-line)
89 (defun gnus-diary-kill-entire-line ()
91 (let ((kill-whole-line t))
95 ;; Summary line format ======================================================
97 (defun gnus-diary-delay-format-french (past delay)
100 ;; Keep only a precision of two degrees
101 (and (> (length delay) 1) (setcdr (cdr delay) nil))
102 (concat (if past "il y a " "dans ")
105 (while (setq del (pop delay))
106 (setq str (concat str
107 (int-to-string (car del)) " "
108 (cond ((eq (cdr del) 'year)
110 ((eq (cdr del) 'month)
112 ((eq (cdr del) 'week)
116 ((eq (cdr del) 'hour)
118 ((eq (cdr del) 'minute)
120 (unless (or (eq (cdr del) 'month)
127 (defun gnus-diary-delay-format-english (past delay)
130 ;; Keep only a precision of two degrees
131 (and (> (length delay) 1) (setcdr (cdr delay) nil))
132 (concat (unless past "in ")
135 (while (setq del (pop delay))
136 (setq str (concat str
137 (int-to-string (car del)) " "
138 (symbol-name (cdr del))
139 (and (> (car del) 1) "s")
145 (defun gnus-diary-header-schedule (headers)
146 ;; Same as `nndiary-schedule', but given a set of headers HEADERS
149 (let ((head (cdr (assoc (intern (format "X-Diary-%s" (car elt)))
152 (nndiary-parse-schedule-value head (cadr elt) (car (cddr elt))))))
155 ;; #### NOTE: Gnus sometimes gives me a HEADER not corresponding to any
156 ;; message, with all fields set to nil here. I don't know what it is for, and
159 (defun gnus-user-format-function-d (header)
160 ;; Return an approximate delay string for the next occurrence of this
161 ;; message. The delay is given only in the first non zero unit.
162 ;; Code partly stolen from article-make-date-line
163 (let* ((extras (mail-header-extra header))
164 (sched (gnus-diary-header-schedule extras))
165 (occur (nndiary-next-occurence sched (current-time)))
167 (real-time (subtract-time occur now)))
170 (let* ((sec (+ (* (float (car real-time)) 65536) (cadr real-time)))
173 (and past (setq sec (- sec)))
175 ;; This is a bit convoluted, but basically we go through the time
176 ;; units for years, weeks, etc, and divide things to see whether
177 ;; that results in positive answers.
178 (let ((units `((year . ,(* 365.25 24 3600))
179 (month . ,(* 31 24 3600))
180 (week . ,(* 7 24 3600))
185 (while (setq unit (pop units))
186 (unless (zerop (setq num (ffloor (/ sec (cdr unit)))))
187 (setq delay (append delay `((,(floor num) . ,(car unit))))))
188 (setq sec (- sec (* num (cdr unit)))))))
189 (funcall gnus-diary-delay-format-function past delay)))
192 ;; #### NOTE: Gnus sometimes gives me a HEADER not corresponding to any
193 ;; message, with all fields set to nil here. I don't know what it is for, and
196 (defun gnus-user-format-function-D (header)
197 ;; Returns a formatted time string for the next occurrence of this message.
198 (let* ((extras (mail-header-extra header))
199 (sched (gnus-diary-header-schedule extras))
200 (occur (nndiary-next-occurence sched (current-time))))
201 (format-time-string gnus-diary-time-format occur)))
204 ;; Article sorting functions ================================================
206 (defun gnus-article-sort-by-schedule (h1 h2)
207 (let* ((now (current-time))
208 (e1 (mail-header-extra h1))
209 (e2 (mail-header-extra h2))
210 (s1 (gnus-diary-header-schedule e1))
211 (s2 (gnus-diary-header-schedule e2))
212 (o1 (nndiary-next-occurence s1 now))
213 (o2 (nndiary-next-occurence s2 now)))
214 (if (and (= (car o1) (car o2)) (= (cadr o1) (cadr o2)))
215 (< (mail-header-number h1) (mail-header-number h2))
216 (time-less-p o1 o2))))
219 (defun gnus-thread-sort-by-schedule (h1 h2)
220 (gnus-article-sort-by-schedule (gnus-thread-header h1)
221 (gnus-thread-header h2)))
223 (defun gnus-summary-sort-by-schedule (&optional reverse)
224 "Sort nndiary summary buffers by schedule of appointments.
225 Optional prefix (or REVERSE argument) means sort in reverse order."
227 (gnus-summary-sort 'schedule reverse))
229 (defvar gnus-summary-misc-menu) ;; Avoid byte compiler warning.
230 (add-hook 'gnus-summary-menu-hook
232 (easy-menu-add-item gnus-summary-misc-menu
235 gnus-summary-sort-by-schedule
236 (eq (car (gnus-find-method-for-group
237 gnus-newsgroup-name))
243 ;; Group parameters autosetting =============================================
245 (defun gnus-diary-update-group-parameters (group)
246 ;; Ensure that nndiary groups have convenient group parameters:
247 ;; - a posting style containing X-Diary headers
248 ;; - a nice summary line format
249 ;; - NNDiary specific sorting by schedule functions
250 ;; In general, try not to mess with what the user might have modified.
253 (let ((posting-style (gnus-group-get-parameter group 'posting-style t))
254 (headers nndiary-headers)
257 (setq header (format "X-Diary-%s" (caar headers))
258 headers (cdr headers))
259 (unless (assoc header posting-style)
260 (setq posting-style (append posting-style (list (list header "*"))))))
261 (gnus-group-set-parameter group 'posting-style posting-style))
262 ;; Summary line format:
263 (unless (gnus-group-get-parameter group 'gnus-summary-line-format t)
264 (gnus-group-set-parameter group 'gnus-summary-line-format
265 `(,gnus-diary-summary-line-format)))
266 ;; Sorting by schedule:
267 (unless (gnus-group-get-parameter group 'gnus-article-sort-functions)
268 (gnus-group-set-parameter group 'gnus-article-sort-functions
269 '((append gnus-article-sort-functions
271 'gnus-article-sort-by-schedule)))))
272 (unless (gnus-group-get-parameter group 'gnus-thread-sort-functions)
273 (gnus-group-set-parameter group 'gnus-thread-sort-functions
274 '((append gnus-thread-sort-functions
276 'gnus-thread-sort-by-schedule))))))
278 ;; Called when a group is subscribed. This is needed because groups created
279 ;; because of mail splitting are *not* created with the back end function.
280 ;; Thus, `nndiary-request-create-group-functions' is inoperative.
281 (defun gnus-diary-maybe-update-group-parameters (group)
282 (when (eq (car (gnus-find-method-for-group group)) 'nndiary)
283 (gnus-diary-update-group-parameters group)))
285 (add-hook 'nndiary-request-create-group-functions
286 'gnus-diary-update-group-parameters)
287 ;; Now that we have `gnus-subscribe-newsgroup-functions', this is not needed
288 ;; anymore. Maybe I should remove this completely.
289 (add-hook 'nndiary-request-update-info-functions
290 'gnus-diary-update-group-parameters)
291 (add-hook 'gnus-subscribe-newsgroup-functions
292 'gnus-diary-maybe-update-group-parameters)
295 ;; Diary Message Checking ===================================================
297 (defvar gnus-diary-header-value-history nil
298 ;; History variable for header value prompting
301 (defun gnus-diary-narrow-to-headers ()
302 "Narrow the current buffer to the header part.
303 Point is left at the beginning of the region.
304 The buffer is assumed to contain a message, but the format is unknown."
305 (cond ((eq major-mode 'message-mode)
306 (message-narrow-to-headers))
308 (goto-char (point-min))
309 (when (search-forward "\n\n" nil t)
310 (narrow-to-region (point-min) (- (point) 1))
311 (goto-char (point-min))))
314 (defun gnus-diary-add-header (str)
315 "Add a header to the current buffer.
316 The buffer is assumed to contain a message, but the format is unknown."
317 (cond ((eq major-mode 'message-mode)
318 (message-add-header str))
321 (gnus-diary-narrow-to-headers)
322 (goto-char (point-max))
323 (if (string-match "\n$" str)
328 (defun gnus-diary-check-message (arg)
329 "Ensure that the current message is a valid for NNDiary.
330 This function checks that all NNDiary required headers are present and
331 valid, and prompts for values / correction otherwise.
333 If ARG (or prefix) is non-nil, force prompting for all fields."
338 (let ((header (concat "X-Diary-" (car head)))
341 ;; First, try to find the header, and checks for validity:
343 (gnus-diary-narrow-to-headers)
344 (when (re-search-forward (concat "^" header ":") nil t)
345 (unless (eq (char-after) ? )
347 (setq value (buffer-substring (point) (point-at-eol)))
348 (and (string-match "[ \t]*\\([^ \t]+\\)[ \t]*" value)
349 (setq value (match-string 1 value)))
351 (nndiary-parse-schedule-value value
352 (nth 1 head) (nth 2 head))
355 ;; #### NOTE: this (along with the `gnus-diary-add-header'
356 ;; function) could be rewritten in a better way, in particular
357 ;; not to blindly remove an already present header and reinsert
358 ;; it somewhere else afterwards.
359 (when (or ask invalid)
360 (gnus-diary-kill-entire-line))
362 ;; Now, loop until a valid value is provided:
363 (while (or ask (not value) invalid)
364 (let ((prompt (concat (and invalid
365 (prog1 "(current value invalid) "
369 (if (listp (nth 1 head))
370 (gnus-completing-read prompt (cons "*" (mapcar 'car (nth 1 head)))
372 'gnus-diary-header-value-history)
373 (read-string prompt value
374 'gnus-diary-header-value-history))))
378 (nndiary-parse-schedule-value value
379 (nth 1 head) (nth 2 head))
382 (gnus-diary-add-header (concat header ": " value))
387 (add-hook 'nndiary-request-accept-article-functions
388 (lambda () (gnus-diary-check-message nil)))
390 (define-key message-mode-map "\C-c\C-fd" 'gnus-diary-check-message)
391 (define-key gnus-article-edit-mode-map "\C-c\C-fd" 'gnus-diary-check-message)
394 ;; The end ==================================================================
396 (defun gnus-diary-version ()
397 "Current Diary back end version."
399 (message "NNDiary version %s" nndiary-version))
401 (provide 'gnus-diary)
403 ;;; gnus-diary.el ends here