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