(require 'nndiary)
(require 'message)
(require 'gnus-art)
(defgroup gnus-diary nil
"Utilities on top of the nndiary back end for Gnus."
:version "22.1"
:group 'gnus)
(defcustom gnus-diary-summary-line-format "%U%R%z %uD: %(%s%) (%ud)\n"
"*Summary line format for nndiary groups."
:type 'string
:group 'gnus-diary
:group 'gnus-summary-format)
(defcustom gnus-diary-time-format "%a, %b %e %y, %H:%M"
"*Time format to display appointements in nndiary summary buffers.
Please refer to `format-time-string' for information on possible values."
:type 'string
:group 'gnus-diary)
(defcustom gnus-diary-delay-format-function 'gnus-diary-delay-format-english
"*Function called to format a diary delay string.
It is passed two arguments. The first one is non-nil if the delay is in
the past. The second one is of the form ((NUM . UNIT) ...) where NUM is
an integer and UNIT is one of 'year 'month 'week 'day 'hour or 'minute.
It should return strings like \"In 2 months, 3 weeks\", \"3 hours,
1 minute ago\" and so on.
There are currently two built-in format functions:
`gnus-diary-delay-format-english' (the default)
`gnus-diary-delay-format-french'"
:type '(choice (const :tag "english" gnus-diary-delay-format-english)
(const :tag "french" gnus-diary-delay-format-french)
(symbol :tag "other"))
:group 'gnus-diary)
(defconst gnus-diary-version nndiary-version
"Current Diary back end version.")
(eval-and-compile
(if (fboundp 'kill-entire-line)
(defalias 'gnus-diary-kill-entire-line 'kill-entire-line)
(defun gnus-diary-kill-entire-line ()
(beginning-of-line)
(let ((kill-whole-line t))
(kill-line)))))
(defun gnus-diary-delay-format-french (past delay)
(if (null delay)
"maintenant!"
(and (> (length delay) 1) (setcdr (cdr delay) nil))
(concat (if past "il y a " "dans ")
(let ((str "")
del)
(while (setq del (pop delay))
(setq str (concat str
(int-to-string (car del)) " "
(cond ((eq (cdr del) 'year)
"an")
((eq (cdr del) 'month)
"mois")
((eq (cdr del) 'week)
"semaine")
((eq (cdr del) 'day)
"jour")
((eq (cdr del) 'hour)
"heure")
((eq (cdr del) 'minute)
"minute"))
(unless (or (eq (cdr del) 'month)
(= (car del) 1))
"s")
(if delay ", "))))
str))))
(defun gnus-diary-delay-format-english (past delay)
(if (null delay)
"now!"
(and (> (length delay) 1) (setcdr (cdr delay) nil))
(concat (unless past "in ")
(let ((str "")
del)
(while (setq del (pop delay))
(setq str (concat str
(int-to-string (car del)) " "
(symbol-name (cdr del))
(and (> (car del) 1) "s")
(if delay ", "))))
str)
(and past " ago"))))
(defun gnus-diary-header-schedule (headers)
(mapcar
(lambda (elt)
(let ((head (cdr (assoc (intern (format "X-Diary-%s" (car elt)))
headers))))
(when head
(nndiary-parse-schedule-value head (cadr elt) (car (cddr elt))))))
nndiary-headers))
(defun gnus-user-format-function-d (header)
(let* ((extras (mail-header-extra header))
(sched (gnus-diary-header-schedule extras))
(occur (nndiary-next-occurence sched (current-time)))
(now (current-time))
(real-time (subtract-time occur now)))
(if (null real-time)
"?????"
(let* ((sec (+ (* (float (car real-time)) 65536) (cadr real-time)))
(past (< sec 0))
delay)
(and past (setq sec (- sec)))
(unless (zerop sec)
(let ((units `((year . ,(* 365.25 24 3600))
(month . ,(* 31 24 3600))
(week . ,(* 7 24 3600))
(day . ,(* 24 3600))
(hour . 3600)
(minute . 60)))
unit num)
(while (setq unit (pop units))
(unless (zerop (setq num (ffloor (/ sec (cdr unit)))))
(setq delay (append delay `((,(floor num) . ,(car unit))))))
(setq sec (- sec (* num (cdr unit)))))))
(funcall gnus-diary-delay-format-function past delay)))
))
(defun gnus-user-format-function-D (header)
(let* ((extras (mail-header-extra header))
(sched (gnus-diary-header-schedule extras))
(occur (nndiary-next-occurence sched (current-time))))
(format-time-string gnus-diary-time-format occur)))
(defun gnus-article-sort-by-schedule (h1 h2)
(let* ((now (current-time))
(e1 (mail-header-extra h1))
(e2 (mail-header-extra h2))
(s1 (gnus-diary-header-schedule e1))
(s2 (gnus-diary-header-schedule e2))
(o1 (nndiary-next-occurence s1 now))
(o2 (nndiary-next-occurence s2 now)))
(if (and (= (car o1) (car o2)) (= (cadr o1) (cadr o2)))
(< (mail-header-number h1) (mail-header-number h2))
(time-less-p o1 o2))))
(defun gnus-thread-sort-by-schedule (h1 h2)
(gnus-article-sort-by-schedule (gnus-thread-header h1)
(gnus-thread-header h2)))
(defun gnus-summary-sort-by-schedule (&optional reverse)
"Sort nndiary summary buffers by schedule of appointements.
Optional prefix (or REVERSE argument) means sort in reverse order."
(interactive "P")
(gnus-summary-sort 'schedule reverse))
(defvar gnus-summary-misc-menu) (add-hook 'gnus-summary-menu-hook
(lambda ()
(easy-menu-add-item gnus-summary-misc-menu
'("Sort")
["Sort by schedule"
gnus-summary-sort-by-schedule
(eq (car (gnus-find-method-for-group
gnus-newsgroup-name))
'nndiary)]
"Sort by number")))
(defun gnus-diary-update-group-parameters (group)
(let ((posting-style (gnus-group-get-parameter group 'posting-style t)))
(mapcar (lambda (elt)
(let ((header (format "X-Diary-%s" (car elt))))
(unless (assoc header posting-style)
(setq posting-style (append posting-style
`((,header "*")))))
))
nndiary-headers)
(gnus-group-set-parameter group 'posting-style posting-style)
(unless (gnus-group-get-parameter group 'gnus-summary-line-format t)
(gnus-group-set-parameter group 'gnus-summary-line-format
`(,gnus-diary-summary-line-format)))
(unless (gnus-group-get-parameter group 'gnus-article-sort-functions)
(gnus-group-set-parameter group 'gnus-article-sort-functions
'((append gnus-article-sort-functions
(list
'gnus-article-sort-by-schedule)))))
(unless (gnus-group-get-parameter group 'gnus-thread-sort-functions)
(gnus-group-set-parameter group 'gnus-thread-sort-functions
'((append gnus-thread-sort-functions
(list
'gnus-thread-sort-by-schedule)))))
))
(defun gnus-diary-maybe-update-group-parameters (group)
(when (eq (car (gnus-find-method-for-group group)) 'nndiary)
(gnus-diary-update-group-parameters group)))
(add-hook 'nndiary-request-create-group-hooks
'gnus-diary-update-group-parameters)
(add-hook 'nndiary-request-update-info-hooks
'gnus-diary-update-group-parameters)
(add-hook 'gnus-subscribe-newsgroup-hooks
'gnus-diary-maybe-update-group-parameters)
(defvar gnus-diary-header-value-history nil
)
(defun gnus-diary-narrow-to-headers ()
"Narrow the current buffer to the header part.
Point is left at the beginning of the region.
The buffer is assumed to contain a message, but the format is unknown."
(cond ((eq major-mode 'message-mode)
(message-narrow-to-headers))
(t
(goto-char (point-min))
(when (search-forward "\n\n" nil t)
(narrow-to-region (point-min) (- (point) 1))
(goto-char (point-min))))
))
(defun gnus-diary-add-header (str)
"Add a header to the current buffer.
The buffer is assumed to contain a message, but the format is unknown."
(cond ((eq major-mode 'message-mode)
(message-add-header str))
(t
(save-restriction
(gnus-diary-narrow-to-headers)
(goto-char (point-max))
(if (string-match "\n$" str)
(insert str)
(insert str ?\n))))
))
(defun gnus-diary-check-message (arg)
"Ensure that the current message is a valid for NNDiary.
This function checks that all NNDiary required headers are present and
valid, and prompts for values / correction otherwise.
If ARG (or prefix) is non-nil, force prompting for all fields."
(interactive "P")
(save-excursion
(mapcar
(lambda (head)
(let ((header (concat "X-Diary-" (car head)))
(ask arg)
value invalid)
(save-restriction
(gnus-diary-narrow-to-headers)
(when (re-search-forward (concat "^" header ":") nil t)
(unless (eq (char-after) ? )
(insert " "))
(setq value (buffer-substring (point) (gnus-point-at-eol)))
(and (string-match "[ \t]*\\([^ \t]+\\)[ \t]*" value)
(setq value (match-string 1 value)))
(condition-case ()
(nndiary-parse-schedule-value value
(nth 1 head) (nth 2 head))
(t
(setq invalid t)))
(when (or ask invalid)
(gnus-diary-kill-entire-line))
))
(while (or ask (not value) invalid)
(let ((prompt (concat (and invalid
(prog1 "(current value invalid) "
(beep)))
header ": ")))
(setq value
(if (listp (nth 1 head))
(completing-read prompt (cons '("*" nil) (nth 1 head))
nil t value
gnus-diary-header-value-history)
(read-string prompt value
gnus-diary-header-value-history))))
(setq ask nil)
(setq invalid nil)
(condition-case ()
(nndiary-parse-schedule-value value
(nth 1 head) (nth 2 head))
(t
(setq invalid t))))
(gnus-diary-add-header (concat header ": " value))
))
nndiary-headers)
))
(add-hook 'nndiary-request-accept-article-hooks
(lambda () (gnus-diary-check-message nil)))
(define-key message-mode-map "\C-cDc" 'gnus-diary-check-message)
(define-key gnus-article-edit-mode-map "\C-cDc" 'gnus-diary-check-message)
(defun gnus-diary-version ()
"Current Diary back end version."
(interactive)
(message "NNDiary version %s" nndiary-version))
(define-key message-mode-map "\C-cDv" 'gnus-diary-version)
(define-key gnus-article-edit-mode-map "\C-cDv" 'gnus-diary-version)
(provide 'gnus-diary)