lisp/gnus/gnus-diary.el

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