lisp/gnus/gnus-diary.el

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