cgit.sxemacs.org Git - gnus/blob - lisp/gnus-diary.el

   1 ;;; gnus-diary.el --- Wrapper around the NNDiary Gnus back end
   2
   3 ;; Copyright (C) 1999-2014 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