lisp/gnus/nndiary.el

   1 ;;; nndiary.el --- A diary back end for Gnus
   2
   3 ;; Copyright (C) 1999-2018 Free Software Foundation, Inc.
   4
   5 ;; Author:        Didier Verna <didier@xemacs.org>
   6 ;; Maintainer:    Didier Verna <didier@xemacs.org>
   7 ;; Created:       Fri Jul 16 18:55:42 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 <https://www.gnu.org/licenses/>.
  24
  25
  26 ;;; Commentary:
  27
  28 ;; Contents management by FCM version 0.1.
  29
  30 ;; Description:
  31 ;; ===========
  32
  33 ;; nndiary is a mail back end designed to handle mails as diary event
  34 ;; reminders. It is now fully documented in the Gnus manual.
  35
  36
  37 ;; Bugs / Todo:
  38 ;; ===========
  39
  40 ;; * Respooling doesn't work because contrary to the request-scan function,
  41 ;;   Gnus won't allow me to override the split methods when calling the
  42 ;;   respooling back end functions.
  43 ;; * There's a bug in the time zone mechanism with variable TZ locations.
  44 ;; * We could allow a keyword like `ask' in X-Diary-* headers, that would mean
  45 ;;   "ask for value upon reception of the message".
  46 ;; * We could add an optional header X-Diary-Reminders to specify a special
  47 ;;   reminders value for this message. Suggested by Jody Klymak.
  48 ;; * We should check messages validity in other circumstances than just
  49 ;;   moving an article from somewhere else (request-accept). For instance,
  50 ;;   when editing / saving and so on.
  51
  52
  53 ;; Remarks:
  54 ;; =======
  55
  56 ;; * nnoo. NNDiary is very similar to nnml. This makes the idea of using nnoo
  57 ;;   (to derive nndiary from nnml) natural. However, my experience with nnoo
  58 ;;   is that for reasonably complex back ends like this one, nnoo is a burden
  59 ;;   rather than an help. It's tricky to use, not everything can be inherited,
  60 ;;   what can be inherited and when is not very clear, and you've got to be
  61 ;;   very careful because a little mistake can fuck up your other back ends,
  62 ;;   especially because their variables will be use instead of your real ones.
  63 ;;   Finally, I found it easier to just clone the needed parts of nnml, and
  64 ;;   tracking nnml updates is not a big deal.
  65
  66 ;;   IMHO, nnoo is actually badly designed.  A much simpler, and yet more
  67 ;;   powerful one would be to make *real* functions and variables for a new
  68 ;;   back end based on another. Lisp is a reflexive language so that's a very
  69 ;;   easy thing to do: inspect the function's form, replace occurrences of
  70 ;;   <nnfrom> (even in strings) with <nnto>, and you're done.
  71
  72 ;; * nndiary-get-new-mail, nndiary-mail-source and nndiary-split-methods:
  73 ;;   NNDiary has some experimental parts, in the sense Gnus normally uses only
  74 ;;   one mail back ends for mail retrieval and splitting. This back end is
  75 ;;   also an attempt to make it behave differently. For Gnus developers: as
  76 ;;   you can see if you snarf into the code, that was not a very difficult
  77 ;;   thing to do. Something should be done about the respooling breakage
  78 ;;   though.
  79
  80
  81 ;;; Code:
  82
  83 (require 'nnoo)
  84 (require 'nnheader)
  85 (require 'nnmail)
  86
  87 (require 'gnus-start)
  88 (require 'gnus-sum)
  89
  90 ;; Back End behavior customization ===========================================
  91
  92 (defgroup nndiary nil
  93   "The Gnus Diary back end."
  94   :version "22.1"
  95   :group 'gnus-diary)
  96
  97 (defcustom nndiary-mail-sources
  98   `((file :path ,(expand-file-name "~/.nndiary")))
  99   "NNDiary specific mail sources.
 100 This variable is used by nndiary in place of the standard `mail-sources'
 101 variable when `nndiary-get-new-mail' is set to non-nil.  These sources
 102 must contain diary messages ONLY."
 103   :group 'nndiary
 104   :group 'mail-source
 105   :type 'sexp)
 106
 107 (defcustom nndiary-split-methods '(("diary" ""))
 108   "NNDiary specific split methods.
 109 This variable is used by nndiary in place of the standard
 110 `nnmail-split-methods' variable when `nndiary-get-new-mail' is set to
 111 non-nil."
 112   :group 'nndiary
 113   :group 'nnmail-split
 114   :type '(choice (repeat :tag "Alist" (group (string :tag "Name") regexp))
 115                  (function-item nnmail-split-fancy)
 116                  (function :tag "Other")))
 117
 118
 119 (defcustom nndiary-reminders '((0 . day))
 120   "Different times when you want to be reminded of your appointments.
 121 Diary articles will appear again, as if they'd been just received.
 122
 123 Entries look like (3 . day) which means something like \"Please
 124 Hortense, would you be so kind as to remind me of my appointments 3 days
 125 before the date, thank you very much. Anda, hmmm... by the way, are you
 126 doing anything special tonight ?\".
 127
 128 The units of measure are 'minute 'hour 'day 'week 'month and 'year (no,
 129 not 'century, sorry).
 130
 131 NOTE: the units of measure actually express dates, not durations: if you
 132 use 'week, messages will pop up on Sundays at 00:00 (or Mondays if
 133 `nndiary-week-starts-on-monday' is non-nil) and *not* 7 days before the
 134 appointment, if you use 'month, messages will pop up on the first day of
 135 each months, at 00:00 and so on.
 136
 137 If you really want to specify a duration (like 24 hours exactly), you can
 138 use the equivalent in minutes (the smallest unit).  A fuzz of 60 seconds
 139 maximum in the reminder is not that painful, I think.  Although this
 140 scheme might appear somewhat weird at a first glance, it is very powerful.
 141 In order to make this clear, here are some examples:
 142
 143 - (0 . day): this is the default value of `nndiary-reminders'.  It means
 144   pop up the appointments of the day each morning at 00:00.
 145
 146 - (1 . day): this means pop up the appointments the day before, at 00:00.
 147
 148 - (6 . hour): for an appointment at 18:30, this would pop up the
 149   appointment message at 12:00.
 150
 151 - (360 . minute): for an appointment at 18:30 and 15 seconds, this would
 152   pop up the appointment message at 12:30."
 153   :group 'nndiary
 154   :type '(repeat (cons :format "%v\n"
 155                        (integer :format "%v")
 156                        (choice :format "%[%v(s)%] before...\n"
 157                                :value day
 158                                (const :format "%v" minute)
 159                                (const :format "%v" hour)
 160                                (const :format "%v" day)
 161                                (const :format "%v" week)
 162                                (const :format "%v" month)
 163                                (const :format "%v" year)))))
 164
 165 (defcustom nndiary-week-starts-on-monday nil
 166   "Whether a week starts on monday (otherwise, sunday)."
 167   :type 'boolean
 168   :group 'nndiary)
 169
 170
 171 (define-obsolete-variable-alias 'nndiary-request-create-group-hooks
 172   'nndiary-request-create-group-functions "24.3")
 173 (defcustom nndiary-request-create-group-functions nil
 174   "Hook run after `nndiary-request-create-group' is executed.
 175 The hook functions will be called with the full group name as argument."
 176   :group 'nndiary
 177   :type 'hook)
 178
 179 (define-obsolete-variable-alias 'nndiary-request-update-info-hooks
 180   'nndiary-request-update-info-functions "24.3")
 181 (defcustom nndiary-request-update-info-functions nil
 182   "Hook run after `nndiary-request-update-info-group' is executed.
 183 The hook functions will be called with the full group name as argument."
 184   :group 'nndiary
 185   :type 'hook)
 186
 187 (define-obsolete-variable-alias 'nndiary-request-accept-article-hooks
 188   'nndiary-request-accept-article-functions "24.3")
 189 (defcustom nndiary-request-accept-article-functions nil
 190   "Hook run before accepting an article.
 191 Executed near the beginning of `nndiary-request-accept-article'.
 192 The hook functions will be called with the article in the current buffer."
 193   :group 'nndiary
 194   :type 'hook)
 195
 196 (defcustom nndiary-check-directory-twice t
 197   "If t, check directories twice to avoid NFS failures."
 198   :group 'nndiary
 199   :type 'boolean)
 200
 201
 202 ;; Back End declaration ======================================================
 203
 204 ;; Well, most of this is nnml clonage.
 205
 206 (nnoo-declare nndiary)
 207
 208 (defvoo nndiary-directory (nnheader-concat gnus-directory "diary/")
 209   "Spool directory for the nndiary back end.")
 210
 211 (defvoo nndiary-active-file
 212     (expand-file-name "active" nndiary-directory)
 213   "Active file for the nndiary back end.")
 214
 215 (defvoo nndiary-newsgroups-file
 216     (expand-file-name "newsgroups" nndiary-directory)
 217   "Newsgroups description file for the nndiary back end.")
 218
 219 (defvoo nndiary-get-new-mail nil
 220   "Whether nndiary gets new mail and split it.
 221 Contrary to traditional mail back ends, this variable can be set to t
 222 even if your primary mail back end also retrieves mail. In such a case,
 223 NDiary uses its own mail-sources and split-methods.")
 224
 225 (defvoo nndiary-nov-is-evil nil
 226   "If non-nil, Gnus will never use nov databases for nndiary groups.
 227 Using nov databases will speed up header fetching considerably.
 228 This variable shouldn't be flipped much.  If you have, for some reason,
 229 set this to t, and want to set it to nil again, you should always run
 230 the `nndiary-generate-nov-databases' command.  The function will go
 231 through all nnml directories and generate nov databases for them
 232 all.  This may very well take some time.")
 233
 234 (defvoo nndiary-prepare-save-mail-hook nil
 235   "Hook run narrowed to an article before saving.")
 236
 237 (defvoo nndiary-inhibit-expiry nil
 238   "If non-nil, inhibit expiry.")
 239
 240 \f
 241
 242 (defconst nndiary-version "0.2-b14"
 243   "Current Diary back end version.")
 244
 245 (defun nndiary-version ()
 246   "Current Diary back end version."
 247   (interactive)
 248   (message "NNDiary version %s" nndiary-version))
 249
 250 (defvoo nndiary-nov-file-name ".overview")
 251
 252 (defvoo nndiary-current-directory nil)
 253 (defvoo nndiary-current-group nil)
 254 (defvoo nndiary-status-string "" )
 255 (defvoo nndiary-nov-buffer-alist nil)
 256 (defvoo nndiary-group-alist nil)
 257 (defvoo nndiary-active-timestamp nil)
 258 (defvoo nndiary-article-file-alist nil)
 259
 260 (defvoo nndiary-generate-active-function 'nndiary-generate-active-info)
 261 (defvoo nndiary-nov-buffer-file-name nil)
 262 (defvoo nndiary-file-coding-system nnmail-file-coding-system)
 263
 264 (defconst nndiary-headers
 265   '(("Minute" 0 59)
 266     ("Hour" 0 23)
 267     ("Dom" 1 31)
 268     ("Month" 1 12)
 269     ("Year" 1971)
 270     ("Dow" 0 6)
 271     ("Time-Zone" (("Y" -43200)
 272
 273                   ("X" -39600)
 274
 275                   ("W" -36000)
 276
 277                   ("V" -32400)
 278
 279                   ("U" -28800)
 280                   ("PST" -28800)
 281
 282                   ("T"   -25200)
 283                   ("MST" -25200)
 284                   ("PDT" -25200)
 285
 286                   ("S"   -21600)
 287                   ("CST" -21600)
 288                   ("MDT" -21600)
 289
 290                   ("R"   -18000)
 291                   ("EST" -18000)
 292                   ("CDT" -18000)
 293
 294                   ("Q"   -14400)
 295                   ("AST" -14400)
 296                   ("EDT" -14400)
 297
 298                   ("P"   -10800)
 299                   ("ADT" -10800)
 300
 301                   ("O" -7200)
 302
 303                   ("N" -3600)
 304
 305                   ("Z"   0)
 306                   ("GMT" 0)
 307                   ("UT"  0)
 308                   ("UTC" 0)
 309                   ("WET" 0)
 310
 311                   ("A"    3600)
 312                   ("CET"  3600)
 313                   ("MET"  3600)
 314                   ("MEZ"  3600)
 315                   ("BST"  3600)
 316                   ("WEST" 3600)
 317
 318                   ("B"    7200)
 319                   ("EET"  7200)
 320                   ("CEST" 7200)
 321                   ("MEST" 7200)
 322                   ("MESZ" 7200)
 323
 324                   ("C" 10800)
 325
 326                   ("D" 14400)
 327
 328                   ("E" 18000)
 329
 330                   ("F" 21600)
 331
 332                   ("G" 25200)
 333
 334                   ("H" 28800)
 335
 336                   ("I"   32400)
 337                   ("JST" 32400)
 338
 339                   ("K"   36000)
 340                   ("GST" 36000)
 341
 342                   ("L" 39600)
 343
 344                   ("M"    43200)
 345                   ("NZST" 43200)
 346
 347                   ("NZDT" 46800))))
 348   ;; List of NNDiary headers that specify the time spec. Each header name is
 349   ;; followed by either two integers (specifying a range of possible values
 350   ;; for this header) or one list (specifying all the possible values for this
 351   ;; header). In the latter case, the list does NOT include the unspecified
 352   ;; spec (*).
 353   ;; For time zone values, we have symbolic time zone names associated with
 354   ;; the (relative) number of seconds ahead GMT.
 355   )
 356
 357 (defsubst nndiary-schedule ()
 358   (let (head)
 359     (condition-case arg
 360         (mapcar
 361          (lambda (elt)
 362            (setq head (nth 0 elt))
 363            (nndiary-parse-schedule (nth 0 elt) (nth 1 elt) (nth 2 elt)))
 364          nndiary-headers)
 365       (error
 366        (nnheader-report 'nndiary "X-Diary-%s header parse error: %s."
 367                         head (cdr arg))
 368        nil))
 369     ))
 370
 371 ;;; Interface functions =====================================================
 372
 373 (nnoo-define-basics nndiary)
 374
 375 (deffoo nndiary-retrieve-headers (sequence &optional group server fetch-old)
 376   (when (nndiary-possibly-change-directory group server)
 377     (with-current-buffer nntp-server-buffer
 378       (erase-buffer)
 379       (let* ((file nil)
 380              (number (length sequence))
 381              (count 0)
 382              (file-name-coding-system nnmail-pathname-coding-system)
 383              beg article
 384              (nndiary-check-directory-twice
 385               (and nndiary-check-directory-twice
 386                    ;; To speed up, disable it in some case.
 387                    (or (not (numberp nnmail-large-newsgroup))
 388                        (<= number nnmail-large-newsgroup)))))
 389         (if (stringp (car sequence))
 390             'headers
 391           (if (nndiary-retrieve-headers-with-nov sequence fetch-old)
 392               'nov
 393             (while sequence
 394               (setq article (car sequence))
 395               (setq file (nndiary-article-to-file article))
 396               (when (and file
 397                          (file-exists-p file)
 398                          (not (file-directory-p file)))
 399                 (insert (format "221 %d Article retrieved.\n" article))
 400                 (setq beg (point))
 401                 (nnheader-insert-head file)
 402                 (goto-char beg)
 403                 (if (search-forward "\n\n" nil t)
 404                     (forward-char -1)
 405                   (goto-char (point-max))
 406                   (insert "\n\n"))
 407                 (insert ".\n")
 408                 (delete-region (point) (point-max)))
 409               (setq sequence (cdr sequence))
 410               (setq count (1+ count))
 411               (and (numberp nnmail-large-newsgroup)
 412                    (> number nnmail-large-newsgroup)
 413                    (zerop (% count 20))
 414                    (nnheader-message 6 "nndiary: Receiving headers... %d%%"
 415                                      (floor (* count 100.0) number))))
 416
 417             (and (numberp nnmail-large-newsgroup)
 418                  (> number nnmail-large-newsgroup)
 419                  (nnheader-message 6 "nndiary: Receiving headers...done"))
 420
 421             (nnheader-fold-continuation-lines)
 422             'headers))))))
 423
 424 (deffoo nndiary-open-server (server &optional defs)
 425   (nnoo-change-server 'nndiary server defs)
 426   (when (not (file-exists-p nndiary-directory))
 427     (ignore-errors (make-directory nndiary-directory t)))
 428   (cond
 429    ((not (file-exists-p nndiary-directory))
 430     (nndiary-close-server)
 431     (nnheader-report 'nndiary "Couldn't create directory: %s"
 432                      nndiary-directory))
 433    ((not (file-directory-p (file-truename nndiary-directory)))
 434     (nndiary-close-server)
 435     (nnheader-report 'nndiary "Not a directory: %s" nndiary-directory))
 436    (t
 437     (nnheader-report 'nndiary "Opened server %s using directory %s"
 438                      server nndiary-directory)
 439     t)))
 440
 441 (deffoo nndiary-request-regenerate (server)
 442   (nndiary-possibly-change-directory nil server)
 443   (nndiary-generate-nov-databases server)
 444   t)
 445
 446 (deffoo nndiary-request-article (id &optional group server buffer)
 447   (nndiary-possibly-change-directory group server)
 448   (let* ((nntp-server-buffer (or buffer nntp-server-buffer))
 449          (file-name-coding-system nnmail-pathname-coding-system)
 450          path gpath group-num)
 451     (if (stringp id)
 452         (when (and (setq group-num (nndiary-find-group-number id))
 453                    (cdr
 454                     (assq (cdr group-num)
 455                           (nnheader-article-to-file-alist
 456                            (setq gpath
 457                                  (nnmail-group-pathname
 458                                   (car group-num)
 459                                   nndiary-directory))))))
 460           (setq path (concat gpath (int-to-string (cdr group-num)))))
 461       (setq path (nndiary-article-to-file id)))
 462     (cond
 463      ((not path)
 464       (nnheader-report 'nndiary "No such article: %s" id))
 465      ((not (file-exists-p path))
 466       (nnheader-report 'nndiary "No such file: %s" path))
 467      ((file-directory-p path)
 468       (nnheader-report 'nndiary "File is a directory: %s" path))
 469      ((not (save-excursion (let ((nnmail-file-coding-system
 470                                   nndiary-file-coding-system))
 471                              (nnmail-find-file path))))
 472       (nnheader-report 'nndiary "Couldn't read file: %s" path))
 473      (t
 474       (nnheader-report 'nndiary "Article %s retrieved" id)
 475       ;; We return the article number.
 476       (cons (if group-num (car group-num) group)
 477             (string-to-number (file-name-nondirectory path)))))))
 478
 479 (deffoo nndiary-request-group (group &optional server dont-check info)
 480   (let ((file-name-coding-system nnmail-pathname-coding-system))
 481     (cond
 482      ((not (nndiary-possibly-change-directory group server))
 483       (nnheader-report 'nndiary "Invalid group (no such directory)"))
 484      ((not (file-exists-p nndiary-current-directory))
 485       (nnheader-report 'nndiary "Directory %s does not exist"
 486                        nndiary-current-directory))
 487      ((not (file-directory-p nndiary-current-directory))
 488       (nnheader-report 'nndiary "%s is not a directory"
 489                        nndiary-current-directory))
 490      (dont-check
 491       (nnheader-report 'nndiary "Group %s selected" group)
 492       t)
 493      (t
 494       (nnheader-re-read-dir nndiary-current-directory)
 495       (nnmail-activate 'nndiary)
 496       (let ((active (nth 1 (assoc group nndiary-group-alist))))
 497         (if (not active)
 498             (nnheader-report 'nndiary "No such group: %s" group)
 499           (nnheader-report 'nndiary "Selected group %s" group)
 500           (nnheader-insert "211 %d %d %d %s\n"
 501                            (max (1+ (- (cdr active) (car active))) 0)
 502                            (car active) (cdr active) group)))))))
 503
 504 (deffoo nndiary-request-scan (&optional group server)
 505   ;; Use our own mail sources and split methods while Gnus doesn't let us have
 506   ;; multiple back ends for retrieving mail.
 507   (let ((mail-sources nndiary-mail-sources)
 508         (nnmail-split-methods nndiary-split-methods))
 509     (setq nndiary-article-file-alist nil)
 510     (nndiary-possibly-change-directory group server)
 511     (nnmail-get-new-mail 'nndiary 'nndiary-save-nov nndiary-directory group)))
 512
 513 (deffoo nndiary-close-group (group &optional server)
 514   (setq nndiary-article-file-alist nil)
 515   t)
 516
 517 (deffoo nndiary-request-create-group (group &optional server args)
 518   (nndiary-possibly-change-directory nil server)
 519   (nnmail-activate 'nndiary)
 520   (cond
 521    ((assoc group nndiary-group-alist)
 522     t)
 523    ((and (file-exists-p (nnmail-group-pathname group nndiary-directory))
 524          (not (file-directory-p (nnmail-group-pathname
 525                                  group nndiary-directory))))
 526     (nnheader-report 'nndiary "%s is a file"
 527                      (nnmail-group-pathname group nndiary-directory)))
 528    (t
 529     (let (active)
 530       (push (list group (setq active (cons 1 0)))
 531             nndiary-group-alist)
 532       (nndiary-possibly-create-directory group)
 533       (nndiary-possibly-change-directory group server)
 534       (let ((articles (nnheader-directory-articles nndiary-current-directory)))
 535         (when articles
 536           (setcar active (apply 'min articles))
 537           (setcdr active (apply 'max articles))))
 538       (nnmail-save-active nndiary-group-alist nndiary-active-file)
 539       (run-hook-with-args 'nndiary-request-create-group-functions
 540                           (gnus-group-prefixed-name group
 541                                                     (list "nndiary" server)))
 542       t))
 543    ))
 544
 545 (deffoo nndiary-request-list (&optional server)
 546   (save-excursion
 547     (let ((nnmail-file-coding-system nnmail-active-file-coding-system)
 548           (file-name-coding-system nnmail-pathname-coding-system))
 549       (nnmail-find-file nndiary-active-file))
 550     (setq nndiary-group-alist (nnmail-get-active))
 551     t))
 552
 553 (deffoo nndiary-request-newgroups (date &optional server)
 554   (nndiary-request-list server))
 555
 556 (deffoo nndiary-request-list-newsgroups (&optional server)
 557   (save-excursion
 558     (nnmail-find-file nndiary-newsgroups-file)))
 559
 560 (deffoo nndiary-request-expire-articles (articles group &optional server force)
 561   (nndiary-possibly-change-directory group server)
 562   (let ((active-articles
 563          (nnheader-directory-articles nndiary-current-directory))
 564         article rest number)
 565     (nnmail-activate 'nndiary)
 566     ;; Articles not listed in active-articles are already gone,
 567     ;; so don't try to expire them.
 568     (setq articles (gnus-intersection articles active-articles))
 569     (while articles
 570       (setq article (nndiary-article-to-file (setq number (pop articles))))
 571       (if (and (nndiary-deletable-article-p group number)
 572                ;; Don't use nnmail-expired-article-p. Our notion of expiration
 573                ;; is a bit peculiar ...
 574                (or force (nndiary-expired-article-p article)))
 575           (progn
 576             ;; Allow a special target group.
 577             (unless (eq nnmail-expiry-target 'delete)
 578               (with-temp-buffer
 579                 (nndiary-request-article number group server (current-buffer))
 580                 (let ((nndiary-current-directory nil))
 581                   (nnmail-expiry-target-group nnmail-expiry-target group)))
 582               (nndiary-possibly-change-directory group server))
 583             (nnheader-message 5 "Deleting article %s in %s" number group)
 584             (condition-case ()
 585                 (funcall nnmail-delete-file-function article)
 586               (file-error (push number rest)))
 587             (setq active-articles (delq number active-articles))
 588             (nndiary-nov-delete-article group number))
 589         (push number rest)))
 590     (let ((active (nth 1 (assoc group nndiary-group-alist))))
 591       (when active
 592         (setcar active (or (and active-articles
 593                                 (apply 'min active-articles))
 594                            (1+ (cdr active)))))
 595       (nnmail-save-active nndiary-group-alist nndiary-active-file))
 596     (nndiary-save-nov)
 597     (nconc rest articles)))
 598
 599 (deffoo nndiary-request-move-article
 600     (article group server accept-form &optional last move-is-internal)
 601   (let ((buf (get-buffer-create " *nndiary move*"))
 602         result)
 603     (nndiary-possibly-change-directory group server)
 604     (nndiary-update-file-alist)
 605     (and
 606      (nndiary-deletable-article-p group article)
 607      (nndiary-request-article article group server)
 608      (let (nndiary-current-directory
 609            nndiary-current-group
 610            nndiary-article-file-alist)
 611        (with-current-buffer buf
 612          (insert-buffer-substring nntp-server-buffer)
 613          (setq result (eval accept-form))
 614          (kill-buffer (current-buffer))
 615          result))
 616      (progn
 617        (nndiary-possibly-change-directory group server)
 618        (condition-case ()
 619            (funcall nnmail-delete-file-function
 620                     (nndiary-article-to-file  article))
 621          (file-error nil))
 622        (nndiary-nov-delete-article group article)
 623        (when last
 624          (nndiary-save-nov)
 625          (nnmail-save-active nndiary-group-alist nndiary-active-file))))
 626     result))
 627
 628 (deffoo nndiary-request-accept-article (group &optional server last)
 629   (nndiary-possibly-change-directory group server)
 630   (nnmail-check-syntax)
 631   (run-hooks 'nndiary-request-accept-article-functions)
 632   (when (nndiary-schedule)
 633     (let (result)
 634       (when nnmail-cache-accepted-message-ids
 635         (nnmail-cache-insert (nnmail-fetch-field "message-id")
 636                              group
 637                              (nnmail-fetch-field "subject")))
 638       (if (stringp group)
 639           (and
 640            (nnmail-activate 'nndiary)
 641            (setq result
 642                  (car (nndiary-save-mail
 643                        (list (cons group (nndiary-active-number group))))))
 644            (progn
 645              (nnmail-save-active nndiary-group-alist nndiary-active-file)
 646              (and last (nndiary-save-nov))))
 647         (and
 648          (nnmail-activate 'nndiary)
 649          (if (and (not (setq result
 650                              (nnmail-article-group 'nndiary-active-number)))
 651                   (yes-or-no-p "Moved to `junk' group; delete article? "))
 652              (setq result 'junk)
 653            (setq result (car (nndiary-save-mail result))))
 654          (when last
 655            (nnmail-save-active nndiary-group-alist nndiary-active-file)
 656            (when nnmail-cache-accepted-message-ids
 657              (nnmail-cache-close))
 658            (nndiary-save-nov))))
 659       result))
 660   )
 661
 662 (deffoo nndiary-request-post (&optional server)
 663   (nnmail-do-request-post 'nndiary-request-accept-article server))
 664
 665 (deffoo nndiary-request-replace-article (article group buffer)
 666   (nndiary-possibly-change-directory group)
 667   (with-current-buffer buffer
 668     (nndiary-possibly-create-directory group)
 669     (let ((chars (nnmail-insert-lines))
 670           (art (concat (int-to-string article) "\t"))
 671           headers)
 672       (when (ignore-errors
 673               (nnmail-write-region
 674                (point-min) (point-max)
 675                (or (nndiary-article-to-file article)
 676                    (expand-file-name (int-to-string article)
 677                                      nndiary-current-directory))
 678                nil (if (nnheader-be-verbose 5) nil 'nomesg))
 679               t)
 680         (setq headers (nndiary-parse-head chars article))
 681         ;; Replace the NOV line in the NOV file.
 682         (with-current-buffer (nndiary-open-nov group)
 683           (goto-char (point-min))
 684           (if (or (looking-at art)
 685                   (search-forward (concat "\n" art) nil t))
 686               ;; Delete the old NOV line.
 687               (delete-region (progn (beginning-of-line) (point))
 688                              (progn (forward-line 1) (point)))
 689             ;; The line isn't here, so we have to find out where
 690             ;; we should insert it.  (This situation should never
 691             ;; occur, but one likes to make sure...)
 692             (while (and (looking-at "[0-9]+\t")
 693                         (< (string-to-number
 694                             (buffer-substring
 695                              (match-beginning 0) (match-end 0)))
 696                            article)
 697                         (zerop (forward-line 1)))))
 698           (beginning-of-line)
 699           (nnheader-insert-nov headers)
 700           (nndiary-save-nov)
 701           t)))))
 702
 703 (deffoo nndiary-request-delete-group (group &optional force server)
 704   (nndiary-possibly-change-directory group server)
 705   (when force
 706     ;; Delete all articles in GROUP.
 707     (let ((articles
 708            (directory-files
 709             nndiary-current-directory t
 710             (concat nnheader-numerical-short-files
 711                     "\\|" (regexp-quote nndiary-nov-file-name) "$")))
 712           article)
 713       (while articles
 714         (setq article (pop articles))
 715         (when (file-writable-p article)
 716           (nnheader-message 5 "Deleting article %s in %s..." article group)
 717           (funcall nnmail-delete-file-function article))))
 718     ;; Try to delete the directory itself.
 719     (ignore-errors (delete-directory nndiary-current-directory)))
 720   ;; Remove the group from all structures.
 721   (setq nndiary-group-alist
 722         (delq (assoc group nndiary-group-alist) nndiary-group-alist)
 723         nndiary-current-group nil
 724         nndiary-current-directory nil)
 725   ;; Save the active file.
 726   (nnmail-save-active nndiary-group-alist nndiary-active-file)
 727   t)
 728
 729 (deffoo nndiary-request-rename-group (group new-name &optional server)
 730   (nndiary-possibly-change-directory group server)
 731   (let ((new-dir (nnmail-group-pathname new-name nndiary-directory))
 732         (old-dir (nnmail-group-pathname group nndiary-directory)))
 733     (when (ignore-errors
 734             (make-directory new-dir t)
 735             t)
 736       ;; We move the articles file by file instead of renaming
 737       ;; the directory -- there may be subgroups in this group.
 738       ;; One might be more clever, I guess.
 739       (let ((files (nnheader-article-to-file-alist old-dir)))
 740         (while files
 741           (rename-file
 742            (concat old-dir (cdar files))
 743            (concat new-dir (cdar files)))
 744           (pop files)))
 745       ;; Move .overview file.
 746       (let ((overview (concat old-dir nndiary-nov-file-name)))
 747         (when (file-exists-p overview)
 748           (rename-file overview (concat new-dir nndiary-nov-file-name))))
 749       (when (<= (length (directory-files old-dir)) 2)
 750         (ignore-errors (delete-directory old-dir)))
 751       ;; That went ok, so we change the internal structures.
 752       (let ((entry (assoc group nndiary-group-alist)))
 753         (when entry
 754           (setcar entry new-name))
 755         (setq nndiary-current-directory nil
 756               nndiary-current-group nil)
 757         ;; Save the new group alist.
 758         (nnmail-save-active nndiary-group-alist nndiary-active-file)
 759         t))))
 760
 761 (deffoo nndiary-set-status (article name value &optional group server)
 762   (nndiary-possibly-change-directory group server)
 763   (let ((file (nndiary-article-to-file article)))
 764     (cond
 765      ((not (file-exists-p file))
 766       (nnheader-report 'nndiary "File %s does not exist" file))
 767      (t
 768       (with-temp-file file
 769         (nnheader-insert-file-contents file)
 770         (nnmail-replace-status name value))
 771       t))))
 772
 773 \f
 774 ;;; Interface optional functions ============================================
 775
 776 (deffoo nndiary-request-update-info (group info &optional server)
 777   (nndiary-possibly-change-directory group)
 778   (let ((timestamp (gnus-group-parameter-value (gnus-info-params info)
 779                                                'timestamp t)))
 780     (if (not timestamp)
 781         (nnheader-report 'nndiary "Group %s doesn't have a timestamp" group)
 782       ;; else
 783       ;; Figure out which articles should be re-new'ed
 784       (let ((articles (nndiary-flatten (gnus-info-read info) 0))
 785             article file unread buf)
 786         (save-excursion
 787           (setq buf (nnheader-set-temp-buffer " *nndiary update*"))
 788           (while (setq article (pop articles))
 789             (setq file (concat nndiary-current-directory
 790                                (int-to-string article)))
 791             (and (file-exists-p file)
 792                  (nndiary-renew-article-p file timestamp)
 793                  (push article unread)))
 794           ;;(message "unread: %s" unread)
 795           (sit-for 1)
 796           (kill-buffer buf))
 797         (setq unread (sort unread '<))
 798         (and unread
 799              (gnus-info-set-read info (gnus-update-read-articles
 800                                        (gnus-info-group info) unread t)))
 801         ))
 802     (run-hook-with-args 'nndiary-request-update-info-functions
 803                         (gnus-info-group info))
 804     t))
 805
 806
 807 \f
 808 ;;; Internal functions ======================================================
 809
 810 (defun nndiary-article-to-file (article)
 811   (nndiary-update-file-alist)
 812   (let (file)
 813     (if (setq file (cdr (assq article nndiary-article-file-alist)))
 814         (expand-file-name file nndiary-current-directory)
 815       ;; Just to make sure nothing went wrong when reading over NFS --
 816       ;; check once more.
 817       (if nndiary-check-directory-twice
 818           (when (file-exists-p
 819                  (setq file (expand-file-name (number-to-string article)
 820                                               nndiary-current-directory)))
 821             (nndiary-update-file-alist t)
 822             file)))))
 823
 824 (defun nndiary-deletable-article-p (group article)
 825   "Say whether ARTICLE in GROUP can be deleted."
 826   (let (path)
 827     (when (setq path (nndiary-article-to-file article))
 828       (when (file-writable-p path)
 829         (or (not nnmail-keep-last-article)
 830             (not (eq (cdr (nth 1 (assoc group nndiary-group-alist)))
 831                      article)))))))
 832
 833 ;; Find an article number in the current group given the Message-ID.
 834 (defun nndiary-find-group-number (id)
 835   (with-current-buffer (get-buffer-create " *nndiary id*")
 836     (let ((alist nndiary-group-alist)
 837           number)
 838       ;; We want to look through all .overview files, but we want to
 839       ;; start with the one in the current directory.  It seems most
 840       ;; likely that the article we are looking for is in that group.
 841       (if (setq number (nndiary-find-id nndiary-current-group id))
 842           (cons nndiary-current-group number)
 843         ;; It wasn't there, so we look through the other groups as well.
 844         (while (and (not number)
 845                     alist)
 846           (or (string= (caar alist) nndiary-current-group)
 847               (setq number (nndiary-find-id (caar alist) id)))
 848           (or number
 849               (setq alist (cdr alist))))
 850         (and number
 851              (cons (caar alist) number))))))
 852
 853 (defun nndiary-find-id (group id)
 854   (erase-buffer)
 855   (let ((nov (expand-file-name nndiary-nov-file-name
 856                                (nnmail-group-pathname group
 857                                                       nndiary-directory)))
 858         number found)
 859     (when (file-exists-p nov)
 860       (nnheader-insert-file-contents nov)
 861       (while (and (not found)
 862                   (search-forward id nil t)) ; We find the ID.
 863         ;; And the id is in the fourth field.
 864         (if (not (and (search-backward "\t" nil t 4)
 865                       (not (search-backward"\t" (point-at-bol) t))))
 866             (forward-line 1)
 867           (beginning-of-line)
 868           (setq found t)
 869           ;; We return the article number.
 870           (setq number
 871                 (ignore-errors (read (current-buffer))))))
 872       number)))
 873
 874 (defun nndiary-retrieve-headers-with-nov (articles &optional fetch-old)
 875   (if (or gnus-nov-is-evil nndiary-nov-is-evil)
 876       nil
 877     (let ((nov (expand-file-name nndiary-nov-file-name
 878                                  nndiary-current-directory)))
 879       (when (file-exists-p nov)
 880         (with-current-buffer nntp-server-buffer
 881           (erase-buffer)
 882           (nnheader-insert-file-contents nov)
 883           (if (and fetch-old
 884                    (not (numberp fetch-old)))
 885               t                         ; Don't remove anything.
 886             (nnheader-nov-delete-outside-range
 887              (if fetch-old (max 1 (- (car articles) fetch-old))
 888                (car articles))
 889              (car (last articles)))
 890             t))))))
 891
 892 (defun nndiary-possibly-change-directory (group &optional server)
 893   (when (and server
 894              (not (nndiary-server-opened server)))
 895     (nndiary-open-server server))
 896   (if (not group)
 897       t
 898     (let ((pathname (nnmail-group-pathname group nndiary-directory))
 899           (file-name-coding-system nnmail-pathname-coding-system))
 900       (when (not (equal pathname nndiary-current-directory))
 901         (setq nndiary-current-directory pathname
 902               nndiary-current-group group
 903               nndiary-article-file-alist nil))
 904       (file-exists-p nndiary-current-directory))))
 905
 906 (defun nndiary-possibly-create-directory (group)
 907   (let ((dir (nnmail-group-pathname group nndiary-directory)))
 908     (unless (file-exists-p dir)
 909       (make-directory (directory-file-name dir) t)
 910       (nnheader-message 5 "Creating mail directory %s" dir))))
 911
 912 (defun nndiary-save-mail (group-art)
 913   "Called narrowed to an article."
 914   (let (chars headers)
 915     (setq chars (nnmail-insert-lines))
 916     (nnmail-insert-xref group-art)
 917     (run-hooks 'nnmail-prepare-save-mail-hook)
 918     (run-hooks 'nndiary-prepare-save-mail-hook)
 919     (goto-char (point-min))
 920     (while (looking-at "From ")
 921       (replace-match "X-From-Line: ")
 922       (forward-line 1))
 923     ;; We save the article in all the groups it belongs in.
 924     (let ((ga group-art)
 925           first)
 926       (while ga
 927         (nndiary-possibly-create-directory (caar ga))
 928         (let ((file (concat (nnmail-group-pathname
 929                              (caar ga) nndiary-directory)
 930                             (int-to-string (cdar ga)))))
 931           (if first
 932               ;; It was already saved, so we just make a hard link.
 933               (funcall nnmail-crosspost-link-function first file t)
 934             ;; Save the article.
 935             (nnmail-write-region (point-min) (point-max) file nil
 936                                  (if (nnheader-be-verbose 5) nil 'nomesg))
 937             (setq first file)))
 938         (setq ga (cdr ga))))
 939     ;; Generate a nov line for this article.  We generate the nov
 940     ;; line after saving, because nov generation destroys the
 941     ;; header.
 942     (setq headers (nndiary-parse-head chars))
 943     ;; Output the nov line to all nov databases that should have it.
 944     (let ((ga group-art))
 945       (while ga
 946         (nndiary-add-nov (caar ga) (cdar ga) headers)
 947         (setq ga (cdr ga))))
 948     group-art))
 949
 950 (defun nndiary-active-number (group)
 951   "Compute the next article number in GROUP."
 952   (let ((active (cadr (assoc group nndiary-group-alist))))
 953     ;; The group wasn't known to nndiary, so we just create an active
 954     ;; entry for it.
 955     (unless active
 956       ;; Perhaps the active file was corrupt?  See whether
 957       ;; there are any articles in this group.
 958       (nndiary-possibly-create-directory group)
 959       (nndiary-possibly-change-directory group)
 960       (unless nndiary-article-file-alist
 961         (setq nndiary-article-file-alist
 962               (sort
 963                (nnheader-article-to-file-alist nndiary-current-directory)
 964                'car-less-than-car)))
 965       (setq active
 966             (if nndiary-article-file-alist
 967                 (cons (caar nndiary-article-file-alist)
 968                       (caar (last nndiary-article-file-alist)))
 969               (cons 1 0)))
 970       (push (list group active) nndiary-group-alist))
 971     (setcdr active (1+ (cdr active)))
 972     (while (file-exists-p
 973             (expand-file-name (int-to-string (cdr active))
 974                               (nnmail-group-pathname group nndiary-directory)))
 975       (setcdr active (1+ (cdr active))))
 976     (cdr active)))
 977
 978 (defun nndiary-add-nov (group article headers)
 979   "Add a nov line for the GROUP base."
 980   (with-current-buffer (nndiary-open-nov group)
 981     (goto-char (point-max))
 982     (mail-header-set-number headers article)
 983     (nnheader-insert-nov headers)))
 984
 985 (defsubst nndiary-header-value ()
 986   (buffer-substring (match-end 0) (progn (end-of-line) (point))))
 987
 988 (defun nndiary-parse-head (chars &optional number)
 989   "Parse the head of the current buffer."
 990   (save-excursion
 991     (save-restriction
 992       (unless (zerop (buffer-size))
 993         (narrow-to-region
 994          (goto-char (point-min))
 995          (if (search-forward "\n\n" nil t) (1- (point)) (point-max))))
 996       (let ((headers (nnheader-parse-naked-head)))
 997         (mail-header-set-chars headers chars)
 998         (mail-header-set-number headers number)
 999         headers))))
1000
1001 (defun nndiary-open-nov (group)
1002   (or (cdr (assoc group nndiary-nov-buffer-alist))
1003       (let ((buffer (get-buffer-create (format " *nndiary overview %s*"
1004                                                group))))
1005         (with-current-buffer buffer
1006           (set (make-local-variable 'nndiary-nov-buffer-file-name)
1007                (expand-file-name
1008                 nndiary-nov-file-name
1009                 (nnmail-group-pathname group nndiary-directory)))
1010           (erase-buffer)
1011           (when (file-exists-p nndiary-nov-buffer-file-name)
1012             (nnheader-insert-file-contents nndiary-nov-buffer-file-name)))
1013         (push (cons group buffer) nndiary-nov-buffer-alist)
1014         buffer)))
1015
1016 (defun nndiary-save-nov ()
1017   (save-excursion
1018     (while nndiary-nov-buffer-alist
1019       (when (buffer-name (cdar nndiary-nov-buffer-alist))
1020         (set-buffer (cdar nndiary-nov-buffer-alist))
1021         (when (buffer-modified-p)
1022           (nnmail-write-region 1 (point-max) nndiary-nov-buffer-file-name
1023                                nil 'nomesg))
1024         (set-buffer-modified-p nil)
1025         (kill-buffer (current-buffer)))
1026       (setq nndiary-nov-buffer-alist (cdr nndiary-nov-buffer-alist)))))
1027
1028 ;;;###autoload
1029 (defun nndiary-generate-nov-databases (&optional server)
1030   "Generate NOV databases in all nndiary directories."
1031   (interactive (list (or (nnoo-current-server 'nndiary) "")))
1032   ;; Read the active file to make sure we don't re-use articles
1033   ;; numbers in empty groups.
1034   (nnmail-activate 'nndiary)
1035   (unless (nndiary-server-opened server)
1036     (nndiary-open-server server))
1037   (setq nndiary-directory (expand-file-name nndiary-directory))
1038   ;; Recurse down the directories.
1039   (nndiary-generate-nov-databases-1 nndiary-directory nil t)
1040   ;; Save the active file.
1041   (nnmail-save-active nndiary-group-alist nndiary-active-file))
1042
1043 (defun nndiary-generate-nov-databases-1 (dir &optional seen no-active)
1044   "Regenerate the NOV database in DIR."
1045   (interactive "DRegenerate NOV in: ")
1046   (setq dir (file-name-as-directory dir))
1047   ;; Only scan this sub-tree if we haven't been here yet.
1048   (unless (member (file-truename dir) seen)
1049     (push (file-truename dir) seen)
1050     ;; We descend recursively
1051     (let ((dirs (directory-files dir t nil t))
1052           dir)
1053       (while (setq dir (pop dirs))
1054         (when (and (not (string-match "^\\." (file-name-nondirectory dir)))
1055                    (file-directory-p dir))
1056           (nndiary-generate-nov-databases-1 dir seen))))
1057     ;; Do this directory.
1058     (let ((nndiary-files (sort (nnheader-article-to-file-alist dir)
1059                        'car-less-than-car)))
1060       (if (not nndiary-files)
1061           (let* ((group (nnheader-file-to-group
1062                          (directory-file-name dir) nndiary-directory))
1063                  (info (cadr (assoc group nndiary-group-alist))))
1064             (when info
1065               (setcar info (1+ (cdr info)))))
1066         (funcall nndiary-generate-active-function dir)
1067         ;; Generate the nov file.
1068         (nndiary-generate-nov-file dir nndiary-files)
1069         (unless no-active
1070           (nnmail-save-active nndiary-group-alist nndiary-active-file))))))
1071
1072 (defvar nndiary-files) ; dynamically bound in nndiary-generate-nov-databases-1
1073 (defun nndiary-generate-active-info (dir)
1074   ;; Update the active info for this group.
1075   (let* ((group (nnheader-file-to-group
1076                  (directory-file-name dir) nndiary-directory))
1077          (entry (assoc group nndiary-group-alist))
1078          (last (or (caadr entry) 0)))
1079     (setq nndiary-group-alist (delq entry nndiary-group-alist))
1080     (push (list group
1081                 (cons (or (caar nndiary-files) (1+ last))
1082                       (max last
1083                            (or (caar (last nndiary-files))
1084                                0))))
1085           nndiary-group-alist)))
1086
1087 (defun nndiary-generate-nov-file (dir files)
1088   (let* ((dir (file-name-as-directory dir))
1089          (nov (concat dir nndiary-nov-file-name))
1090          (nov-buffer (get-buffer-create " *nov*"))
1091          chars file headers)
1092     ;; Init the nov buffer.
1093     (with-current-buffer nov-buffer
1094       (buffer-disable-undo)
1095       (erase-buffer)
1096       (set-buffer nntp-server-buffer)
1097       ;; Delete the old NOV file.
1098       (when (file-exists-p nov)
1099         (funcall nnmail-delete-file-function nov))
1100       (while files
1101         (unless (file-directory-p (setq file (concat dir (cdar files))))
1102           (erase-buffer)
1103           (nnheader-insert-file-contents file)
1104           (narrow-to-region
1105            (goto-char (point-min))
1106            (progn
1107              (search-forward "\n\n" nil t)
1108              (setq chars (- (point-max) (point)))
1109              (max 1 (1- (point)))))
1110           (unless (zerop (buffer-size))
1111             (goto-char (point-min))
1112             (setq headers (nndiary-parse-head chars (caar files)))
1113             (with-current-buffer nov-buffer
1114               (goto-char (point-max))
1115               (nnheader-insert-nov headers)))
1116           (widen))
1117         (setq files (cdr files)))
1118       (with-current-buffer nov-buffer
1119         (nnmail-write-region 1 (point-max) nov nil 'nomesg)
1120         (kill-buffer (current-buffer))))))
1121
1122 (defun nndiary-nov-delete-article (group article)
1123   (with-current-buffer (nndiary-open-nov group)
1124     (when (nnheader-find-nov-line article)
1125       (delete-region (point) (progn (forward-line 1) (point)))
1126       (when (bobp)
1127         (let ((active (cadr (assoc group nndiary-group-alist)))
1128               num)
1129           (when active
1130             (if (eobp)
1131                 (setf (car active) (1+ (cdr active)))
1132               (when (and (setq num (ignore-errors (read (current-buffer))))
1133                          (numberp num))
1134                 (setf (car active) num)))))))
1135     t))
1136
1137 (defun nndiary-update-file-alist (&optional force)
1138   (when (or (not nndiary-article-file-alist)
1139             force)
1140     (setq nndiary-article-file-alist
1141           (nnheader-article-to-file-alist nndiary-current-directory))))
1142
1143
1144 (defun nndiary-string-to-number (str min &optional max)
1145   ;; Like `string-to-number' but barf if STR is not exactly an integer, and not
1146   ;; within the specified bounds.
1147   ;; Signals are caught by `nndiary-schedule'.
1148   (if (not (string-match "^[ \t]*[0-9]+[ \t]*$" str))
1149       (error "Not an integer value")
1150     ;; else
1151     (let ((val (string-to-number str)))
1152       (and (or (< val min)
1153                (and max (> val max)))
1154            (error "Value out of range"))
1155       val)))
1156
1157 (defun nndiary-parse-schedule-value (str min-or-values max)
1158   ;; Parse the schedule string STR, or signal an error.
1159   ;; Signals are caught by `nndiary-schedule'.
1160   (if (string-match "[ \t]*\\*[ \t]*" str)
1161       ;; unspecified
1162       nil
1163     ;; specified
1164     (if (listp min-or-values)
1165         ;; min-or-values is values
1166         ;; #### NOTE: this is actually only a hack for time zones.
1167         (let ((val (and (string-match "[ \t]*\\([^ \t]+\\)[ \t]*" str)
1168                         (match-string 1 str))))
1169           (if (and val (setq val (assoc val min-or-values)))
1170               (list (cadr val))
1171             (error "Invalid syntax")))
1172       ;; min-or-values is min
1173       (mapcar
1174        (lambda (val)
1175          (let ((res (split-string val "-")))
1176            (cond
1177             ((= (length res) 1)
1178              (nndiary-string-to-number (car res) min-or-values max))
1179             ((= (length res) 2)
1180              ;; don't know if crontab accepts this, but ensure
1181              ;; that BEG is <= END
1182              (let ((beg (nndiary-string-to-number (car res) min-or-values max))
1183                    (end (nndiary-string-to-number (cadr res) min-or-values max)))
1184                (cond ((< beg end)
1185                       (cons beg end))
1186                      ((= beg end)
1187                       beg)
1188                      (t
1189                       (cons end beg)))))
1190             (t
1191              (error "Invalid syntax")))
1192            ))
1193        (split-string str ",")))
1194     ))
1195
1196 ;; ### FIXME: remove this function if it's used only once.
1197 (defun nndiary-parse-schedule (head min-or-values max)
1198   ;; Parse the cron-like value of header X-Diary-HEAD in current buffer.
1199   ;; - Returns nil if `*'
1200   ;; - Otherwise returns a list of integers and/or ranges (BEG . END)
1201   ;; The exception is the Timze-Zone value which is always of the form (STR).
1202   ;; Signals are caught by `nndiary-schedule'.
1203   (let ((header (format "^X-Diary-%s: \\(.*\\)$" head)))
1204     (goto-char (point-min))
1205     (if (not (re-search-forward header nil t))
1206         (error "Header missing")
1207       ;; else
1208       (nndiary-parse-schedule-value (match-string 1) min-or-values max))
1209     ))
1210
1211 (defun nndiary-max (spec)
1212   ;; Returns the max of specification SPEC, or nil for permanent schedules.
1213   (unless (null spec)
1214     (let ((elts spec)
1215           (max 0)
1216           elt)
1217       (while (setq elt (pop elts))
1218         (if (integerp elt)
1219             (and (> elt max) (setq max elt))
1220           (and (> (cdr elt) max) (setq max (cdr elt)))))
1221       max)))
1222
1223 (defun nndiary-flatten (spec min &optional max)
1224   ;; flatten the spec by expanding ranges to all possible values.
1225   (let (flat n)
1226     (cond ((null spec)
1227            ;; this happens when I flatten something else than one of my
1228            ;; schedules (a list of read articles for instance).
1229            (unless (null max)
1230              (setq n min)
1231              (while (<= n max)
1232                (push n flat)
1233                (setq n (1+ n)))))
1234           (t
1235            (let ((elts spec)
1236                  elt)
1237              (while (setq elt (pop elts))
1238                (if (integerp elt)
1239                    (push elt flat)
1240                  ;; else
1241                  (setq n (car elt))
1242                  (while (<= n (cdr elt))
1243                    (push n flat)
1244                    (setq n (1+ n))))))))
1245     flat))
1246
1247 (defun nndiary-unflatten (spec)
1248   ;; opposite of flatten: build ranges if possible
1249   (setq spec (sort spec '<))
1250   (let (min max res)
1251     (while (setq min (pop spec))
1252       (setq max min)
1253       (while (and (car spec) (= (car spec) (1+ max)))
1254         (setq max (1+ max))
1255         (pop spec))
1256       (if (= max min)
1257           (setq res (append res (list min)))
1258         (setq res (append res (list (cons min max))))))
1259     res))
1260
1261 (defun nndiary-compute-reminders (date)
1262   ;; Returns a list of times corresponding to the reminders of date DATE.
1263   ;; See the comment in `nndiary-reminders' about rounding.
1264   (let* ((reminders nndiary-reminders)
1265          (date-elts (decode-time date))
1266          ;; ### NOTE: out-of-range values are accepted by encode-time. This
1267          ;; makes our life easier.
1268          (monday (- (nth 3 date-elts)
1269                     (if nndiary-week-starts-on-monday
1270                         (if (zerop (nth 6 date-elts))
1271                             6
1272                           (- (nth 6 date-elts) 1))
1273                       (nth 6 date-elts))))
1274          reminder res)
1275     ;; remove the DOW and DST entries
1276     (setcdr (nthcdr 5 date-elts) (nthcdr 8 date-elts))
1277     (while (setq reminder (pop reminders))
1278       (push
1279        (cond ((eq (cdr reminder) 'minute)
1280               (time-subtract
1281                (apply 'encode-time 0 (nthcdr 1 date-elts))
1282                (seconds-to-time (* (car reminder) 60.0))))
1283              ((eq (cdr reminder) 'hour)
1284               (time-subtract
1285                (apply 'encode-time 0 0 (nthcdr 2 date-elts))
1286                (seconds-to-time (* (car reminder) 3600.0))))
1287              ((eq (cdr reminder) 'day)
1288               (time-subtract
1289                (apply 'encode-time 0 0 0 (nthcdr 3 date-elts))
1290                (seconds-to-time (* (car reminder) 86400.0))))
1291              ((eq (cdr reminder) 'week)
1292               (time-subtract
1293                (apply 'encode-time 0 0 0 monday (nthcdr 4 date-elts))
1294                (seconds-to-time (* (car reminder) 604800.0))))
1295              ((eq (cdr reminder) 'month)
1296               (time-subtract
1297                (apply 'encode-time 0 0 0 1 (nthcdr 4 date-elts))
1298                (seconds-to-time (* (car reminder) 18748800.0))))
1299              ((eq (cdr reminder) 'year)
1300               (time-subtract
1301                (apply 'encode-time 0 0 0 1 1 (nthcdr 5 date-elts))
1302                (seconds-to-time (* (car reminder) 400861056.0)))))
1303        res))
1304     (sort res 'time-less-p)))
1305
1306 (defun nndiary-last-occurrence (sched)
1307   ;; Returns the last occurrence of schedule SCHED as an Emacs time struct, or
1308   ;; nil for permanent schedule or errors.
1309   (let ((minute (nndiary-max (nth 0 sched)))
1310         (hour (nndiary-max (nth 1 sched)))
1311         (year (nndiary-max (nth 4 sched)))
1312         (time-zone (or (and (nth 6 sched) (car (nth 6 sched)))
1313                        (current-time-zone))))
1314     (when year
1315       (or minute (setq minute 59))
1316       (or hour (setq hour 23))
1317       ;; I'll just compute all possible values and test them by decreasing
1318       ;; order until one succeeds. This is probably quite rude, but I got
1319       ;; bored in finding a good algorithm for doing that ;-)
1320       ;; ### FIXME: remove identical entries.
1321       (let ((dom-list (nth 2 sched))
1322             (month-list (sort (nndiary-flatten (nth 3 sched) 1 12) '>))
1323             (year-list (sort (nndiary-flatten (nth 4 sched) 1971) '>))
1324             (dow-list (nth 5 sched)))
1325         ;; Special case: an asterisk in one of the days specifications means
1326         ;; that only the other should be taken into account. If both are
1327         ;; unspecified, you would get all possible days in both.
1328         (cond ((null dow-list)
1329                ;; this gets all days if dom-list is nil
1330                (setq dom-list (nndiary-flatten dom-list 1 31)))
1331               ((null dom-list)
1332                ;; this also gets all days if dow-list is nil
1333                (setq dow-list (nndiary-flatten dow-list 0 6)))
1334               (t
1335                (setq dom-list (nndiary-flatten dom-list 1 31))
1336                (setq dow-list (nndiary-flatten dow-list 0 6))))
1337         (or
1338          (catch 'found
1339            (while (setq year (pop year-list))
1340              (let ((months month-list)
1341                    month)
1342                (while (setq month (pop months))
1343                  ;; Now we must merge the Dows with the Doms. To do that, we
1344                  ;; have to know which day is the 1st one for this month.
1345                  ;; Maybe there's simpler, but decode-time(encode-time) will
1346                  ;; give us the answer.
1347                  (let ((first (nth 6 (decode-time
1348                                       (encode-time 0 0 0 1 month year
1349                                                    time-zone))))
1350                        (max (cond ((= month 2)
1351                                    (if (date-leap-year-p year) 29 28))
1352                                   ((<= month 7)
1353                                    (if (zerop (% month 2)) 30 31))
1354                                   (t
1355                                    (if (zerop (% month 2)) 31 30))))
1356                        (doms dom-list)
1357                        (dows dow-list)
1358                        day days)
1359                    ;; first, review the doms to see if they are valid.
1360                    (while (setq day (pop doms))
1361                      (and (<= day max)
1362                           (push day days)))
1363                    ;; second add all possible dows
1364                    (while (setq day (pop dows))
1365                      ;; days start at 1.
1366                      (setq day (1+ (- day first)))
1367                      (and (< day 0) (setq day (+ 7 day)))
1368                      (while (<= day max)
1369                        (push day days)
1370                        (setq day (+ 7 day))))
1371                    ;; Finally, if we have some days, they are valid
1372                    (when days
1373                      (sort days '>)
1374                      (throw 'found
1375                             (encode-time 0 minute hour
1376                                          (car days) month year time-zone)))
1377                    )))))
1378          ;; There's an upper limit, but we didn't find any last occurrence.
1379          ;; This means that the schedule is undecidable. This can happen if
1380          ;; you happen to say something like "each Feb 31 until 2038".
1381          (progn
1382            (nnheader-report 'nndiary "Undecidable schedule")
1383            nil))
1384         ))))
1385 (define-obsolete-function-alias
1386   'nndiary-last-occurence
1387   'nndiary-last-occurrence "26.1")
1388
1389 (defun nndiary-next-occurrence (sched now)
1390   ;; Returns the next occurrence of schedule SCHED, starting from time NOW.
1391   ;; If there's no next occurrence, returns the last one (if any) which is then
1392   ;; in the past.
1393   (let* ((today (decode-time now))
1394          (this-minute (nth 1 today))
1395          (this-hour (nth 2 today))
1396          (this-day (nth 3 today))
1397          (this-month (nth 4 today))
1398          (this-year (nth 5 today))
1399          (minute-list (sort (nndiary-flatten (nth 0 sched) 0 59) '<))
1400          (hour-list (sort (nndiary-flatten (nth 1 sched) 0 23) '<))
1401          (dom-list (nth 2 sched))
1402          (month-list (sort (nndiary-flatten (nth 3 sched) 1 12) '<))
1403          (years (if (nth 4 sched)
1404                     (sort (nndiary-flatten (nth 4 sched) 1971) '<)
1405                   t))
1406          (dow-list (nth 5 sched))
1407          (year (1- this-year))
1408          (time-zone (or (and (nth 6 sched) (car (nth 6 sched)))
1409                         (current-time-zone))))
1410     ;; Special case: an asterisk in one of the days specifications means that
1411     ;; only the other should be taken into account. If both are unspecified,
1412     ;; you would get all possible days in both.
1413     (cond ((null dow-list)
1414            ;; this gets all days if dom-list is nil
1415            (setq dom-list (nndiary-flatten dom-list 1 31)))
1416           ((null dom-list)
1417            ;; this also gets all days if dow-list is nil
1418            (setq dow-list (nndiary-flatten dow-list 0 6)))
1419           (t
1420            (setq dom-list (nndiary-flatten dom-list 1 31))
1421            (setq dow-list (nndiary-flatten dow-list 0 6))))
1422     ;; Remove past years.
1423     (unless (eq years t)
1424       (while (and (car years) (< (car years) this-year))
1425         (pop years)))
1426     (if years
1427         ;; Because we might not be limited in years, we must guard against
1428         ;; infinite loops. Appart from cases like Feb 31, there are probably
1429         ;; other ones, (no monday XXX 2nd etc). I don't know any algorithm to
1430         ;; decide this, so I assume that if we reach 10 years later, the
1431         ;; schedule is undecidable.
1432         (or
1433          (catch 'found
1434            (while (if (eq years t)
1435                       (and (setq year (1+ year))
1436                            (<= year (+ 10 this-year)))
1437                     (setq year (pop years)))
1438              (let ((months month-list)
1439                    month)
1440                ;; Remove past months for this year.
1441                (and (= year this-year)
1442                     (while (and (car months) (< (car months) this-month))
1443                       (pop months)))
1444                (while (setq month (pop months))
1445                  ;; Now we must merge the Dows with the Doms. To do that, we
1446                  ;; have to know which day is the 1st one for this month.
1447                  ;; Maybe there's simpler, but decode-time(encode-time) will
1448                  ;; give us the answer.
1449                  (let ((first (nth 6 (decode-time
1450                                       (encode-time 0 0 0 1 month year
1451                                                    time-zone))))
1452                        (max (cond ((= month 2)
1453                                    (if (date-leap-year-p year) 29 28))
1454                                   ((<= month 7)
1455                                    (if (zerop (% month 2)) 30 31))
1456                                   (t
1457                                    (if (zerop (% month 2)) 31 30))))
1458                        (doms dom-list)
1459                        (dows dow-list)
1460                        day days)
1461                    ;; first, review the doms to see if they are valid.
1462                    (while (setq day (pop doms))
1463                      (and (<= day max)
1464                           (push day days)))
1465                    ;; second add all possible dows
1466                    (while (setq day (pop dows))
1467                      ;; days start at 1.
1468                      (setq day (1+ (- day first)))
1469                      (and (< day 0) (setq day (+ 7 day)))
1470                      (while (<= day max)
1471                        (push day days)
1472                        (setq day (+ 7 day))))
1473                    ;; Aaaaaaall right. Now we have a valid list of DAYS for
1474                    ;; this month and this year.
1475                    (when days
1476                      (setq days (sort days '<))
1477                      ;; Remove past days for this year and this month.
1478                      (and (= year this-year)
1479                           (= month this-month)
1480                           (while (and (car days) (< (car days) this-day))
1481                             (pop days)))
1482                      (while (setq day (pop days))
1483                        (let ((hours hour-list)
1484                              hour)
1485                          ;; Remove past hours for this year, this month and
1486                          ;; this day.
1487                          (and (= year this-year)
1488                               (= month this-month)
1489                               (= day this-day)
1490                               (while (and (car hours)
1491                                           (< (car hours) this-hour))
1492                                 (pop hours)))
1493                          (while (setq hour (pop hours))
1494                            (let ((minutes minute-list)
1495                                  minute)
1496                              ;; Remove past hours for this year, this month,
1497                              ;; this day and this hour.
1498                              (and (= year this-year)
1499                                   (= month this-month)
1500                                   (= day this-day)
1501                                   (= hour this-hour)
1502                                   (while (and (car minutes)
1503                                               (< (car minutes) this-minute))
1504                                     (pop minutes)))
1505                              (while (setq minute (pop minutes))
1506                                ;; Ouch! Here, we've got a complete valid
1507                                ;; schedule. It's a good one if it's in the
1508                                ;; future.
1509                                (let ((time (encode-time 0 minute hour day
1510                                                         month year
1511                                                         time-zone)))
1512                                  (and (time-less-p now time)
1513                                       (throw 'found time)))
1514                                ))))
1515                        ))
1516                    )))
1517              ))
1518          (nndiary-last-occurrence sched))
1519       ;; else
1520       (nndiary-last-occurrence sched))
1521     ))
1522 (define-obsolete-function-alias
1523   'nndiary-next-occurence
1524   'nndiary-next-occurrence "26.1")
1525
1526 (defun nndiary-expired-article-p (file)
1527   (with-temp-buffer
1528     (if (nnheader-insert-head file)
1529         (let ((sched (nndiary-schedule)))
1530           ;; An article has expired if its last schedule (if any) is in the
1531           ;; past. A permanent schedule never expires.
1532           (and sched
1533                (setq sched (nndiary-last-occurrence sched))
1534                (time-less-p sched nil)))
1535       ;; else
1536       (nnheader-report 'nndiary "Could not read file %s" file)
1537       nil)
1538     ))
1539
1540 (defun nndiary-renew-article-p (file timestamp)
1541   (erase-buffer)
1542   (if (nnheader-insert-head file)
1543       (let ((now (current-time))
1544             (sched (nndiary-schedule)))
1545         ;; The article should be re-considered as unread if there's a reminder
1546         ;; between the group timestamp and the current time.
1547         (when (and sched (setq sched (nndiary-next-occurrence sched now)))
1548           (let ((reminders ;; add the next occurrence itself at the end.
1549                  (append (nndiary-compute-reminders sched) (list sched))))
1550             (while (and reminders (time-less-p (car reminders) timestamp))
1551               (pop reminders))
1552             ;; The reminders might be empty if the last date is in the past,
1553             ;; or we've got at least the next occurrence itself left. All past
1554             ;; dates are renewed.
1555             (or (not reminders)
1556                 (time-less-p (car reminders) now)))
1557           ))
1558     ;; else
1559     (nnheader-report 'nndiary "Could not read file %s" file)
1560     nil))
1561
1562 ;; The end... ===============================================================
1563
1564 (dolist (header nndiary-headers)
1565   (setq header (intern (format "X-Diary-%s" (car header))))
1566   ;; Required for building NOV databases and some other stuff.
1567   (add-to-list 'gnus-extra-headers header)
1568   (add-to-list 'nnmail-extra-headers header))
1569
1570 (unless (assoc "nndiary" gnus-valid-select-methods)
1571   (gnus-declare-backend "nndiary" 'post-mail 'respool 'address))
1572
1573 (provide 'nndiary)
1574
1575 ;;; nndiary.el ends here