lisp/gnus/gnus-diary.el

   1 ;;; gnus-diary.el --- Wrapper around the NNDiary Gnus back end
   2
   3 ;; Copyright (C) 1999-2015 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 (eval-and-compile
  87   (if (fboundp 'kill-entire-line)
  88       (defalias 'gnus-diary-kill-entire-line 'kill-entire-line)
  89     (defun gnus-diary-kill-entire-line ()
  90       (beginning-of-line)
  91       (let ((kill-whole-line t))
  92         (kill-line)))))
  93
  94
  95 ;; Summary line format ======================================================
  96
  97 (defun gnus-diary-delay-format-french (past delay)
  98   (if (null delay)
  99       "maintenant!"
 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 ")
 103             (let ((str "")
 104                   del)
 105               (while (setq del (pop delay))
 106                 (setq str (concat str
 107                                   (int-to-string (car del)) " "
 108                                   (cond ((eq (cdr del) 'year)
 109                                          "an")
 110                                         ((eq (cdr del) 'month)
 111                                          "mois")
 112                                         ((eq (cdr del) 'week)
 113                                          "semaine")
 114                                         ((eq (cdr del) 'day)
 115                                          "jour")
 116                                         ((eq (cdr del) 'hour)
 117                                          "heure")
 118                                         ((eq (cdr del) 'minute)
 119                                          "minute"))
 120                                   (unless (or (eq (cdr del) 'month)
 121                                               (= (car del) 1))
 122                                     "s")
 123                                   (if delay ", "))))
 124               str))))
 125
 126
 127 (defun gnus-diary-delay-format-english (past delay)
 128   (if (null delay)
 129       "now!"
 130     ;; Keep only a precision of two degrees
 131     (and (> (length delay) 1) (setcdr (cdr delay) nil))
 132     (concat (unless past "in ")
 133             (let ((str "")
 134                   del)
 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")
 140                                   (if delay ", "))))
 141               str)
 142             (and past " ago"))))
 143
 144
 145 (defun gnus-diary-header-schedule (headers)
 146   ;; Same as `nndiary-schedule', but given a set of headers HEADERS
 147   (mapcar
 148    (lambda (elt)
 149      (let ((head (cdr (assoc (intern (format "X-Diary-%s" (car elt)))
 150                              headers))))
 151        (when head
 152          (nndiary-parse-schedule-value head (cadr elt) (car (cddr elt))))))
 153    nndiary-headers))
 154
 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
 157 ;; I just ignore it.
 158 ;;;###autoload
 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)))
 166          (now (current-time))
 167          (real-time (subtract-time occur now)))
 168     (if (null real-time)
 169         "?????"
 170       (let* ((sec (+ (* (float (car real-time)) 65536) (cadr real-time)))
 171              (past (< sec 0))
 172              delay)
 173         (and past (setq sec (- sec)))
 174         (unless (zerop 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))
 181                          (day . ,(* 24 3600))
 182                          (hour . 3600)
 183                          (minute . 60)))
 184                 unit num)
 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)))
 190     ))
 191
 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
 194 ;; I just ignore it.
 195 ;;;###autoload
 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)))
 202
 203
 204 ;; Article sorting functions ================================================
 205
 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))))
 217
 218
 219 (defun gnus-thread-sort-by-schedule (h1 h2)
 220   (gnus-article-sort-by-schedule (gnus-thread-header h1)
 221                                  (gnus-thread-header h2)))
 222
 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."
 226   (interactive "P")
 227   (gnus-summary-sort 'schedule reverse))
 228
 229 (defvar gnus-summary-misc-menu) ;; Avoid byte compiler warning.
 230 (add-hook 'gnus-summary-menu-hook
 231           (lambda ()
 232             (easy-menu-add-item gnus-summary-misc-menu
 233                                 '("Sort")
 234                                 ["Sort by schedule"
 235                                  gnus-summary-sort-by-schedule
 236                                  (eq (car (gnus-find-method-for-group
 237                                            gnus-newsgroup-name))
 238                                      'nndiary)]
 239                                 "Sort by number")))
 240
 241
 242
 243 ;; Group parameters autosetting =============================================
 244
 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.
 251
 252   ;; Posting style:
 253   (let ((posting-style (gnus-group-get-parameter group 'posting-style t))
 254         (headers nndiary-headers)
 255         header)
 256     (while 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
 270                                         (list
 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
 275                                         (list
 276                                          'gnus-thread-sort-by-schedule))))))
 277
 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)))
 284
 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)
 293
 294
 295 ;; Diary Message Checking ===================================================
 296
 297 (defvar gnus-diary-header-value-history nil
 298   ;; History variable for header value prompting
 299   )
 300
 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))
 307         (t
 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))))
 312         ))
 313
 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))
 319         (t
 320          (save-restriction
 321            (gnus-diary-narrow-to-headers)
 322            (goto-char (point-max))
 323            (if (string-match "\n$" str)
 324                (insert str)
 325              (insert str ?\n))))
 326         ))
 327
 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.
 332
 333 If ARG (or prefix) is non-nil, force prompting for all fields."
 334   (interactive "P")
 335   (save-excursion
 336     (mapcar
 337      (lambda (head)
 338        (let ((header (concat "X-Diary-" (car head)))
 339              (ask arg)
 340              value invalid)
 341          ;; First, try to find the header, and checks for validity:
 342          (save-restriction
 343            (gnus-diary-narrow-to-headers)
 344            (when (re-search-forward (concat "^" header ":") nil t)
 345              (unless (eq (char-after) ? )
 346                (insert " "))
 347              (setq value (buffer-substring (point) (point-at-eol)))
 348              (and (string-match "[ \t]*\\([^ \t]+\\)[ \t]*" value)
 349                   (setq value (match-string 1 value)))
 350              (condition-case ()
 351                  (nndiary-parse-schedule-value value
 352                                                (nth 1 head) (nth 2 head))
 353                (error
 354                 (setq invalid t)))
 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))
 361              ))
 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) "
 366                                         (beep)))
 367                                  header ": ")))
 368              (setq value
 369                    (if (listp (nth 1 head))
 370                        (gnus-completing-read prompt (cons "*" (mapcar 'car (nth 1 head)))
 371                                              t value
 372                                              'gnus-diary-header-value-history)
 373                      (read-string prompt value
 374                                   'gnus-diary-header-value-history))))
 375            (setq ask nil)
 376            (setq invalid nil)
 377            (condition-case ()
 378                (nndiary-parse-schedule-value value
 379                                              (nth 1 head) (nth 2 head))
 380              (error
 381               (setq invalid t))))
 382          (gnus-diary-add-header (concat header ": " value))
 383          ))
 384      nndiary-headers)
 385     ))
 386
 387 (add-hook 'nndiary-request-accept-article-functions
 388           (lambda () (gnus-diary-check-message nil)))
 389
 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)
 392
 393
 394 ;; The end ==================================================================
 395
 396 (defun gnus-diary-version ()
 397   "Current Diary back end version."
 398   (interactive)
 399   (message "NNDiary version %s" nndiary-version))
 400
 401 (provide 'gnus-diary)
 402
 403 ;;; gnus-diary.el ends here