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