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