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

   1 ;;; nnml.el --- mail spool access for Gnus
   2 ;; Copyright (C) 1995,96 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
   5 ;;      Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
   6 ;; Keywords: news, mail
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; Based on nnspool.el by Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>.
  28 ;; For an overview of what the interface functions do, please see the
  29 ;; Gnus sources.
  30
  31 ;;; Code:
  32
  33 (require 'nnheader)
  34 (require 'nnmail)
  35 (eval-when-compile (require 'cl))
  36
  37 (defvar nnml-directory "~/Mail/"
  38   "Mail spool directory.")
  39
  40 (defvar nnml-active-file
  41   (concat (file-name-as-directory nnml-directory) "active")
  42   "Mail active file.")
  43
  44 (defvar nnml-newsgroups-file
  45   (concat (file-name-as-directory nnml-directory) "newsgroups")
  46   "Mail newsgroups description file.")
  47
  48 (defvar nnml-get-new-mail t
  49   "If non-nil, nnml will check the incoming mail file and split the mail.")
  50
  51 (defvar nnml-nov-is-evil nil
  52   "If non-nil, Gnus will never generate and use nov databases for mail groups.
  53 Using nov databases will speed up header fetching considerably.
  54 This variable shouldn't be flipped much. If you have, for some reason,
  55 set this to t, and want to set it to nil again, you should always run
  56 the `nnml-generate-nov-databases' command. The function will go
  57 through all nnml directories and generate nov databases for them
  58 all. This may very well take some time.")
  59
  60 (defvar nnml-prepare-save-mail-hook nil
  61   "Hook run narrowed to an article before saving.")
  62
  63 \f
  64
  65 (defconst nnml-version "nnml 1.0"
  66   "nnml version.")
  67
  68 (defvar nnml-nov-file-name ".overview")
  69
  70 (defvar nnml-current-directory nil)
  71 (defvar nnml-current-group nil)
  72 (defvar nnml-status-string "")
  73 (defvar nnml-nov-buffer-alist nil)
  74 (defvar nnml-group-alist nil)
  75 (defvar nnml-active-timestamp nil)
  76 (defvar nnml-article-file-alist nil)
  77
  78 (defvar nnml-generate-active-function 'nnml-generate-active-info)
  79
  80 \f
  81
  82 ;; Server variables.
  83
  84 (defvar nnml-current-server nil)
  85 (defvar nnml-server-alist nil)
  86 (defvar nnml-server-variables
  87   `((nnml-directory ,nnml-directory)
  88     (nnml-active-file ,nnml-active-file)
  89     (nnml-newsgroups-file ,nnml-newsgroups-file)
  90     (nnml-get-new-mail ,nnml-get-new-mail)
  91     (nnml-nov-is-evil ,nnml-nov-is-evil)
  92     (nnml-nov-file-name ,nnml-nov-file-name)
  93     (nnml-current-directory nil)
  94     (nnml-generate-active-function ,nnml-generate-active-function)
  95     (nnml-article-file-alist nil)
  96     (nnml-prepare-save-mail-hook nil)
  97     (nnml-current-group nil)
  98     (nnml-status-string "")
  99     (nnml-nov-buffer-alist nil)
 100     (nnml-group-alist nil)
 101     (nnml-active-timestamp nil)))
 102
 103 \f
 104
 105 ;;; Interface functions.
 106
 107 (defun nnml-retrieve-headers (sequence &optional newsgroup server fetch-old)
 108   (save-excursion
 109     (set-buffer nntp-server-buffer)
 110     (erase-buffer)
 111     (let ((file nil)
 112           (number (length sequence))
 113           (count 0)
 114           beg article)
 115       (if (stringp (car sequence))
 116           'headers
 117         (nnml-possibly-change-directory newsgroup)
 118         (unless nnml-article-file-alist
 119           (setq nnml-article-file-alist
 120                 (nnheader-article-to-file-alist nnml-current-directory)))
 121         (if (nnml-retrieve-headers-with-nov sequence fetch-old)
 122             'nov
 123           (while sequence
 124             (setq article (car sequence))
 125             (setq file
 126                   (concat nnml-current-directory
 127                           (or (cdr (assq article nnml-article-file-alist))
 128                               "")))
 129             (if (and (file-exists-p file)
 130                      (not (file-directory-p file)))
 131                 (progn
 132                   (insert (format "221 %d Article retrieved.\n" article))
 133                   (setq beg (point))
 134                   (nnheader-insert-head file)
 135                   (goto-char beg)
 136                   (if (search-forward "\n\n" nil t)
 137                       (forward-char -1)
 138                     (goto-char (point-max))
 139                     (insert "\n\n"))
 140                   (insert ".\n")
 141                   (delete-region (point) (point-max))))
 142             (setq sequence (cdr sequence))
 143             (setq count (1+ count))
 144             (and (numberp nnmail-large-newsgroup)
 145                  (> number nnmail-large-newsgroup)
 146                  (zerop (% count 20))
 147                  (nnheader-message 6 "nnml: Receiving headers... %d%%"
 148                                    (/ (* count 100) number))))
 149
 150           (and (numberp nnmail-large-newsgroup)
 151                (> number nnmail-large-newsgroup)
 152                (nnheader-message 6 "nnml: Receiving headers...done"))
 153
 154           (nnheader-fold-continuation-lines)
 155           'headers)))))
 156
 157 (defun nnml-open-server (server &optional defs)
 158   (nnheader-change-server 'nnml server defs)
 159   (when (not (file-exists-p nnml-directory))
 160     (condition-case ()
 161         (make-directory nnml-directory t)
 162       (error t)))
 163   (cond
 164    ((not (file-exists-p nnml-directory))
 165     (nnml-close-server)
 166     (nnheader-report 'nnml "Couldn't create directory: %s" nnml-directory))
 167    ((not (file-directory-p (file-truename nnml-directory)))
 168     (nnml-close-server)
 169     (nnheader-report 'nnml "Not a directory: %s" nnml-directory))
 170    (t
 171     (nnheader-report 'nnml "Opened server %s using directory %s"
 172                      server nnml-directory)
 173     t)))
 174
 175 (defun nnml-close-server (&optional server)
 176   (setq nnml-current-server nil
 177         nnml-group-alist nil)
 178   t)
 179
 180 (defun nnml-server-opened (&optional server)
 181   (and (equal server nnml-current-server)
 182        nntp-server-buffer
 183        (buffer-name nntp-server-buffer)))
 184
 185 (defun nnml-status-message (&optional server)
 186   nnml-status-string)
 187
 188 (defun nnml-request-article (id &optional newsgroup server buffer)
 189   (nnml-possibly-change-directory newsgroup)
 190   (let* ((nntp-server-buffer (or buffer nntp-server-buffer))
 191          file path gpath group-num)
 192     (if (stringp id)
 193         (when (and (setq group-num (nnml-find-group-number id))
 194                    (setq file (cdr
 195                                (assq (cdr group-num)
 196                                      (nnheader-article-to-file-alist
 197                                       (setq gpath
 198                                             (nnmail-group-pathname
 199                                              (car group-num)
 200                                              nnml-directory)))))))
 201           (setq path (concat gpath (int-to-string (cdr group-num)))))
 202       (unless nnml-article-file-alist
 203         (setq nnml-article-file-alist
 204               (nnheader-article-to-file-alist nnml-current-directory)))
 205       (when (setq file (cdr (assq id nnml-article-file-alist)))
 206         (setq path (concat nnml-current-directory file))))
 207     (cond
 208      ((not path)
 209       (nnheader-report 'nnml "No such article: %s" id))
 210      ((not (file-exists-p path))
 211       (nnheader-report 'nnml "No such file: %s" path))
 212      ((file-directory-p path)
 213       (nnheader-report 'nnml "File is a directory: %s" path))
 214      ((not (save-excursion (nnmail-find-file path)))
 215       (nnheader-report 'nnml "Couldn't read file: %s" path))
 216      (t
 217       (nnheader-report 'nnml "Article %s retrieved" id)
 218       ;; We return the article number.
 219       (cons newsgroup (string-to-int (file-name-nondirectory path)))))))
 220
 221 (defun nnml-request-group (group &optional server dont-check)
 222   (cond
 223    ((not (nnml-possibly-change-directory group))
 224     (nnheader-report 'nnml "Invalid group (no such directory)"))
 225    (dont-check
 226     (nnheader-report 'nnml "Group %s selected" group)
 227     t)
 228    (t
 229     (nnmail-activate 'nnml)
 230     (let ((active (nth 1 (assoc group nnml-group-alist))))
 231       (if (not active)
 232           (nnheader-report 'nnml "No such group: %s" group)
 233         (nnheader-report 'nnml "Selected group %s" group)
 234         (nnheader-insert "211 %d %d %d %s\n"
 235                          (max (1+ (- (cdr active) (car active))) 0)
 236                          (car active) (cdr active) group))))))
 237
 238 (defun nnml-request-scan (&optional group server)
 239   (setq nnml-article-file-alist nil)
 240   (nnmail-get-new-mail 'nnml 'nnml-save-nov nnml-directory group))
 241
 242 (defun nnml-close-group (group &optional server)
 243   t)
 244
 245 (defun nnml-request-close ()
 246   (setq nnml-current-server nil)
 247   (setq nnml-server-alist nil)
 248   t)
 249
 250 (defun nnml-request-create-group (group &optional server)
 251   (nnmail-activate 'nnml)
 252   (or (assoc group nnml-group-alist)
 253       (let (active)
 254         (setq nnml-group-alist (cons (list group (setq active (cons 1 0)))
 255                                      nnml-group-alist))
 256         (nnml-possibly-create-directory group)
 257         (nnml-possibly-change-directory group)
 258         (let ((articles
 259                (nnheader-directory-articles nnml-current-directory )))
 260           (and articles
 261                (progn
 262                  (setcar active (apply 'min articles))
 263                  (setcdr active (apply 'max articles)))))
 264         (nnmail-save-active nnml-group-alist nnml-active-file)))
 265   t)
 266
 267 (defun nnml-request-list (&optional server)
 268   (save-excursion
 269     (nnmail-find-file nnml-active-file)
 270     (setq nnml-group-alist (nnmail-get-active))))
 271
 272 (defun nnml-request-newgroups (date &optional server)
 273   (nnml-request-list server))
 274
 275 (defun nnml-request-list-newsgroups (&optional server)
 276   (save-excursion
 277     (nnmail-find-file nnml-newsgroups-file)))
 278
 279 (defun nnml-request-expire-articles (articles newsgroup &optional server force)
 280   (nnml-possibly-change-directory newsgroup)
 281   (let* ((active-articles
 282           (nnheader-directory-articles nnml-current-directory))
 283          (is-old t)
 284          article rest mod-time number)
 285     (nnmail-activate 'nnml)
 286
 287     (unless nnml-article-file-alist
 288       (setq nnml-article-file-alist
 289             (nnheader-article-to-file-alist nnml-current-directory)))
 290
 291     (while (and articles is-old)
 292       (setq article (concat nnml-current-directory
 293                             (int-to-string
 294                              (setq number (pop articles)))))
 295       (when (setq mod-time (nth 5 (file-attributes article)))
 296         (if (and (nnml-deletable-article-p newsgroup number)
 297                  (setq is-old
 298                        (nnmail-expired-article-p newsgroup mod-time force)))
 299             (progn
 300               (nnheader-message 5 "Deleting article %s in %s..."
 301                                 article newsgroup)
 302               (condition-case ()
 303                   (funcall nnmail-delete-file-function article)
 304                 (file-error
 305                  (push number rest)))
 306               (setq active-articles (delq number active-articles))
 307               (nnml-nov-delete-article newsgroup number))
 308           (push number rest))))
 309     (let ((active (nth 1 (assoc newsgroup nnml-group-alist))))
 310       (when active
 311         (setcar active (or (and active-articles
 312                                 (apply 'min active-articles))
 313                            (1+ (cdr active)))))
 314       (nnmail-save-active nnml-group-alist nnml-active-file))
 315     (nnml-save-nov)
 316     (message "")
 317     (nconc rest articles)))
 318
 319 (defun nnml-request-move-article
 320   (article group server accept-form &optional last)
 321   (let ((buf (get-buffer-create " *nnml move*"))
 322         result)
 323     (nnml-possibly-change-directory group)
 324     (unless nnml-article-file-alist
 325       (setq nnml-article-file-alist
 326             (nnheader-article-to-file-alist nnml-current-directory)))
 327     (and
 328      (nnml-deletable-article-p group article)
 329      (nnml-request-article article group server)
 330      (save-excursion
 331        (set-buffer buf)
 332        (insert-buffer-substring nntp-server-buffer)
 333        (setq result (eval accept-form))
 334        (kill-buffer (current-buffer))
 335        result)
 336      (progn
 337        (condition-case ()
 338            (funcall nnmail-delete-file-function
 339                     (concat nnml-current-directory
 340                             (int-to-string article)))
 341          (file-error nil))
 342        (nnml-nov-delete-article group article)
 343        (and last (nnml-save-nov))))
 344     result))
 345
 346 (defun nnml-request-accept-article (group &optional last)
 347   (let (result)
 348     (if (stringp group)
 349         (and
 350          (nnmail-activate 'nnml)
 351          ;; We trick the choosing function into believing that only one
 352          ;; group is available.
 353          (let ((nnmail-split-methods (list (list group ""))))
 354            (setq result (car (nnml-save-mail))))
 355          (progn
 356            (nnmail-save-active nnml-group-alist nnml-active-file)
 357            (and last (nnml-save-nov))))
 358       (and
 359        (nnmail-activate 'nnml)
 360        (setq result (car (nnml-save-mail)))
 361        (progn
 362          (nnmail-save-active nnml-group-alist nnml-active-file)
 363          (and last (nnml-save-nov)))))
 364     result))
 365
 366 (defun nnml-request-replace-article (article group buffer)
 367   (nnml-possibly-change-directory group)
 368   (save-excursion
 369     (set-buffer buffer)
 370     (nnml-possibly-create-directory group)
 371     (if (not (condition-case ()
 372                  (progn
 373                    (write-region (point-min) (point-max)
 374                                  (concat nnml-current-directory
 375                                          (int-to-string article))
 376                                  nil (if (nnheader-be-verbose 5) nil 'nomesg))
 377                    t)
 378                (error nil)))
 379         ()
 380       (let ((chars (nnmail-insert-lines))
 381             (art (concat (int-to-string article) "\t"))
 382             nov-line)
 383         (setq nov-line (nnml-make-nov-line chars))
 384         ;; Replace the NOV line in the NOV file.
 385         (save-excursion
 386           (set-buffer (nnml-open-nov group))
 387           (goto-char (point-min))
 388           (if (or (looking-at art)
 389                   (search-forward (concat "\n" art) nil t))
 390               ;; Delete the old NOV line.
 391               (delete-region (progn (beginning-of-line) (point))
 392                              (progn (forward-line 1) (point)))
 393             ;; The line isn't here, so we have to find out where
 394             ;; we should insert it. (This situation should never
 395             ;; occur, but one likes to make sure...)
 396             (while (and (looking-at "[0-9]+\t")
 397                         (< (string-to-int
 398                             (buffer-substring
 399                              (match-beginning 0) (match-end 0)))
 400                            article)
 401                         (zerop (forward-line 1)))))
 402           (beginning-of-line)
 403           (insert (int-to-string article) nov-line)
 404           (nnml-save-nov)
 405           t)))))
 406
 407 (defun nnml-request-delete-group (group &optional force server)
 408   (nnml-possibly-change-directory group)
 409   (when force
 410     ;; Delete all articles in GROUP.
 411     (let ((articles
 412            (directory-files
 413             nnml-current-directory t
 414             (concat nnheader-numerical-short-files
 415                     "\\|" (regexp-quote nnml-nov-file-name) "$")))
 416           article)
 417       (while articles
 418         (setq article (pop articles))
 419         (when (file-writable-p article)
 420           (nnheader-message 5 "Deleting article %s in %s..." article group)
 421           (funcall nnmail-delete-file-function article))))
 422     ;; Try to delete the directory itself.
 423     (condition-case ()
 424         (delete-directory nnml-current-directory)
 425       (error nil)))
 426   ;; Remove the group from all structures.
 427   (setq nnml-group-alist
 428         (delq (assoc group nnml-group-alist) nnml-group-alist)
 429         nnml-current-group nil
 430         nnml-current-directory nil)
 431   ;; Save the active file.
 432   (nnmail-save-active nnml-group-alist nnml-active-file)
 433   t)
 434
 435 (defun nnml-request-rename-group (group new-name &optional server)
 436   (nnml-possibly-change-directory group)
 437   ;; Rename directory.
 438   (and (file-writable-p nnml-current-directory)
 439        (condition-case ()
 440            (let ((parent
 441                   (file-name-directory
 442                    (directory-file-name
 443                     (nnmail-group-pathname new-name nnml-directory)))))
 444              (unless (file-exists-p parent)
 445                (make-directory parent t))
 446              (rename-file
 447               (directory-file-name nnml-current-directory)
 448               (directory-file-name
 449                (nnmail-group-pathname new-name nnml-directory)))
 450              t)
 451          (error nil))
 452        ;; That went ok, so we change the internal structures.
 453        (let ((entry (assoc group nnml-group-alist)))
 454          (and entry (setcar entry new-name))
 455          (setq nnml-current-directory nil
 456                nnml-current-group nil)
 457          ;; Save the new group alist.
 458          (nnmail-save-active nnml-group-alist nnml-active-file)
 459          t)))
 460
 461 \f
 462 ;;; Internal functions.
 463
 464 (defun nnml-deletable-article-p (group article)
 465   "Say whether ARTICLE in GROUP can be deleted."
 466   (let (file path)
 467     (when (setq file (cdr (assq article nnml-article-file-alist)))
 468       (setq path (concat nnml-current-directory file))
 469       (and (file-writable-p path)
 470            (or (not nnmail-keep-last-article)
 471                (not (eq (cdr (nth 1 (assoc group nnml-group-alist)))
 472                         article)))))))
 473
 474 ;; Find an article number in the current group given the Message-ID.
 475 (defun nnml-find-group-number (id)
 476   (save-excursion
 477     (set-buffer (get-buffer-create " *nnml id*"))
 478     (buffer-disable-undo (current-buffer))
 479     (let ((alist nnml-group-alist)
 480           number)
 481       ;; We want to look through all .overview files, but we want to
 482       ;; start with the one in the current directory.  It seems most
 483       ;; likely that the article we are looking for is in that group.
 484       (if (setq number (nnml-find-id nnml-current-group id))
 485           (cons nnml-current-group number)
 486         ;; It wasn't there, so we look through the other groups as well.
 487         (while (and (not number)
 488                     alist)
 489           (or (string= (caar alist) nnml-current-group)
 490               (setq number (nnml-find-id (caar alist) id)))
 491           (or number
 492               (setq alist (cdr alist))))
 493         (and number
 494              (cons (caar alist) number))))))
 495
 496 (defun nnml-find-id (group id)
 497   (erase-buffer)
 498   (let ((nov (concat (nnmail-group-pathname group nnml-directory)
 499                      nnml-nov-file-name))
 500         number found)
 501     (when (file-exists-p nov)
 502       (insert-file-contents nov)
 503       (while (and (not found)
 504                   (search-forward id nil t)) ; We find the ID.
 505         ;; And the id is in the fourth field.
 506         (if (search-backward
 507              "\t" (save-excursion (beginning-of-line) (point)) t 4)
 508             (progn
 509               (beginning-of-line)
 510               (setq found t)
 511               ;; We return the article number.
 512               (setq number
 513                     (condition-case ()
 514                         (read (current-buffer))
 515                       (error nil))))))
 516       number)))
 517
 518 (defun nnml-retrieve-headers-with-nov (articles &optional fetch-old)
 519   (if (or gnus-nov-is-evil nnml-nov-is-evil)
 520       nil
 521     (let ((first (car articles))
 522           (last (progn (while (cdr articles) (setq articles (cdr articles)))
 523                        (car articles)))
 524           (nov (concat nnml-current-directory nnml-nov-file-name)))
 525       (if (file-exists-p nov)
 526           (save-excursion
 527             (set-buffer nntp-server-buffer)
 528             (erase-buffer)
 529             (insert-file-contents nov)
 530             (if (and fetch-old
 531                      (not (numberp fetch-old)))
 532                 t                       ; Don't remove anything.
 533               (if fetch-old
 534                   (setq first (max 1 (- first fetch-old))))
 535               (goto-char (point-min))
 536               (while (and (not (eobp)) (< first (read (current-buffer))))
 537                 (forward-line 1))
 538               (beginning-of-line)
 539               (if (not (eobp)) (delete-region 1 (point)))
 540               (while (and (not (eobp)) (>= last (read (current-buffer))))
 541                 (forward-line 1))
 542               (beginning-of-line)
 543               (if (not (eobp)) (delete-region (point) (point-max)))
 544               t))))))
 545
 546 (defun nnml-possibly-change-directory (group &optional force)
 547   (when group
 548     (let ((pathname (nnmail-group-pathname group nnml-directory)))
 549       (when (or force
 550                 (not (equal pathname nnml-current-directory)))
 551         (setq nnml-current-directory pathname
 552               nnml-current-group group
 553               nnml-article-file-alist nil))))
 554   t)
 555
 556 (defun nnml-possibly-create-directory (group)
 557   (let (dir dirs)
 558     (setq dir (nnmail-group-pathname group nnml-directory))
 559     (while (not (file-directory-p dir))
 560       (setq dirs (cons dir dirs))
 561       (setq dir (file-name-directory (directory-file-name dir))))
 562     (while dirs
 563       (make-directory (directory-file-name (car dirs)))
 564       (nnheader-message 5 "Creating mail directory %s" (car dirs))
 565       (setq dirs (cdr dirs)))))
 566
 567 (defun nnml-save-mail ()
 568   "Called narrowed to an article."
 569   (let ((group-art (nreverse (nnmail-article-group 'nnml-active-number)))
 570         chars nov-line)
 571     (setq chars (nnmail-insert-lines))
 572     (nnmail-insert-xref group-art)
 573     (run-hooks 'nnml-prepare-save-mail-hook)
 574     (goto-char (point-min))
 575     (while (looking-at "From ")
 576       (replace-match "X-From-Line: ")
 577       (forward-line 1))
 578     ;; We save the article in all the newsgroups it belongs in.
 579     (let ((ga group-art)
 580           first)
 581       (while ga
 582         (nnml-possibly-create-directory (caar ga))
 583         (let ((file (concat (nnmail-group-pathname
 584                              (caar ga) nnml-directory)
 585                             (int-to-string (cdar ga)))))
 586           (if first
 587               ;; It was already saved, so we just make a hard link.
 588               (funcall nnmail-crosspost-link-function first file t)
 589             ;; Save the article.
 590             (write-region (point-min) (point-max) file nil
 591                           (if (nnheader-be-verbose 5) nil 'nomesg))
 592             (setq first file)))
 593         (setq ga (cdr ga))))
 594     ;; Generate a nov line for this article. We generate the nov
 595     ;; line after saving, because nov generation destroys the
 596     ;; header.
 597     (setq nov-line (nnml-make-nov-line chars))
 598     ;; Output the nov line to all nov databases that should have it.
 599     (let ((ga group-art))
 600       (while ga
 601         (nnml-add-nov (caar ga) (cdar ga) nov-line)
 602         (setq ga (cdr ga))))
 603     group-art))
 604
 605 (defun nnml-active-number (group)
 606   "Compute the next article number in GROUP."
 607   (let ((active (cadr (assoc group nnml-group-alist))))
 608     ;; The group wasn't known to nnml, so we just create an active
 609     ;; entry for it.
 610     (or active
 611         (progn
 612           (setq active (cons 1 0))
 613           (setq nnml-group-alist (cons (list group active) nnml-group-alist))))
 614     (setcdr active (1+ (cdr active)))
 615     (while (file-exists-p
 616             (concat (nnmail-group-pathname group nnml-directory)
 617                     (int-to-string (cdr active))))
 618       (setcdr active (1+ (cdr active))))
 619     (cdr active)))
 620
 621 (defun nnml-add-nov (group article line)
 622   "Add a nov line for the GROUP base."
 623   (save-excursion
 624     (set-buffer (nnml-open-nov group))
 625     (goto-char (point-max))
 626     (insert (int-to-string article) line)))
 627
 628 (defsubst nnml-header-value ()
 629   (buffer-substring (match-end 0) (progn (end-of-line) (point))))
 630
 631 (defun nnml-make-nov-line (chars)
 632   "Create a nov from the current headers."
 633   (let ((case-fold-search t)
 634         subject from date id references lines xref in-reply-to char)
 635     (save-excursion
 636       (save-restriction
 637         (goto-char (point-min))
 638         (narrow-to-region
 639          (point)
 640          (1- (or (search-forward "\n\n" nil t) (point-max))))
 641         ;; Fold continuation lines.
 642         (goto-char (point-min))
 643         (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
 644           (replace-match " " t t))
 645         (subst-char-in-region (point-min) (point-max) ?\t ? )
 646         ;; [number subject from date id references chars lines xref]
 647         (save-excursion
 648           (goto-char (point-min))
 649           (while (re-search-forward "^\\(from\\|subject\\|message-id\\|date\\|lines\\|xref\\|references\\|in-reply-to\\): "
 650                                     nil t)
 651             (beginning-of-line)
 652             (setq char (downcase (following-char)))
 653             (cond
 654              ((eq char ?s)
 655               (setq subject (nnml-header-value)))
 656              ((eq char ?f)
 657               (setq from (nnml-header-value)))
 658              ((eq char ?x)
 659               (setq xref (buffer-substring (match-beginning 0)
 660                                            (progn (end-of-line) (point)))))
 661              ((eq char ?l)
 662               (setq lines (nnml-header-value)))
 663              ((eq char ?d)
 664               (setq date (nnml-header-value)))
 665              ((eq char ?m)
 666               (setq id (setq id (nnml-header-value))))
 667              ((eq char ?r)
 668               (setq references (nnml-header-value)))
 669              ((eq char ?i)
 670               (setq in-reply-to (nnml-header-value))))
 671             (forward-line 1))
 672
 673           (and (not references)
 674                in-reply-to
 675                (string-match "<[^>]+>" in-reply-to)
 676                (setq references
 677                      (substring in-reply-to (match-beginning 0)
 678                                 (match-end 0)))))
 679         ;; [number subject from date id references chars lines xref]
 680         (format "\t%s\t%s\t%s\t%s\t%s\t%d\t%s\t%s\t\n"
 681                 (or subject "(none)") (or from "(nobody)") (or date "")
 682                 (or id (nnmail-message-id))
 683                 (or references "") (or chars 0) (or lines "0")
 684                 (or xref ""))))))
 685
 686 (defun nnml-open-nov (group)
 687   (or (cdr (assoc group nnml-nov-buffer-alist))
 688       (let ((buffer (find-file-noselect
 689                      (concat (nnmail-group-pathname group nnml-directory)
 690                              nnml-nov-file-name))))
 691         (save-excursion
 692           (set-buffer buffer)
 693           (buffer-disable-undo (current-buffer)))
 694         (setq nnml-nov-buffer-alist
 695               (cons (cons group buffer) nnml-nov-buffer-alist))
 696         buffer)))
 697
 698 (defun nnml-save-nov ()
 699   (save-excursion
 700     (while nnml-nov-buffer-alist
 701       (when (buffer-name (cdar nnml-nov-buffer-alist))
 702         (set-buffer (cdar nnml-nov-buffer-alist))
 703         (and (buffer-modified-p)
 704              (write-region
 705               1 (point-max) (buffer-file-name) nil 'nomesg))
 706         (set-buffer-modified-p nil)
 707         (kill-buffer (current-buffer)))
 708       (setq nnml-nov-buffer-alist (cdr nnml-nov-buffer-alist)))))
 709
 710 ;;;###autoload
 711 (defun nnml-generate-nov-databases ()
 712   "Generate nov databases in all nnml directories."
 713   (interactive)
 714   ;; Read the active file to make sure we don't re-use articles
 715   ;; numbers in empty groups.
 716   (nnmail-activate 'nnml)
 717   (nnml-open-server (or nnml-current-server ""))
 718   (setq nnml-directory (expand-file-name nnml-directory))
 719   ;; Recurse down the directories.
 720   (nnml-generate-nov-databases-1 nnml-directory)
 721   ;; Save the active file.
 722   (nnmail-save-active nnml-group-alist nnml-active-file))
 723
 724 (defun nnml-generate-nov-databases-1 (dir)
 725   (setq dir (file-name-as-directory dir))
 726   ;; We descend recursively
 727   (let ((dirs (directory-files dir t nil t))
 728         dir)
 729     (while dirs
 730       (setq dir (pop dirs))
 731       (when (and (not (string-match "/\\.\\.?$" dir))
 732                  (file-directory-p dir))
 733         (nnml-generate-nov-databases-1 dir))))
 734   ;; Do this directory.
 735   (let ((files (sort
 736                 (mapcar
 737                  (lambda (name) (string-to-int name))
 738                  (directory-files dir nil "^[0-9]+$" t))
 739                 '<)))
 740     (when files
 741       (funcall nnml-generate-active-function dir)
 742       ;; Generate the nov file.
 743       (nnml-generate-nov-file dir files))))
 744
 745 (defun nnml-generate-active-info (dir)
 746   ;; Update the active info for this group.
 747   (let ((group (nnheader-file-to-group
 748                 (directory-file-name dir) nnml-directory)))
 749     (setq nnml-group-alist
 750           (delq (assoc group nnml-group-alist) nnml-group-alist))
 751     (push (list group
 752                 (cons (car files)
 753                       (let ((f files))
 754                         (while (cdr f) (setq f (cdr f)))
 755                         (car f))))
 756           nnml-group-alist)))
 757
 758 (defun nnml-generate-nov-file (dir files)
 759   (let* ((dir (file-name-as-directory dir))
 760          (nov (concat dir nnml-nov-file-name))
 761          (nov-buffer (get-buffer-create " *nov*"))
 762          nov-line chars file)
 763     (save-excursion
 764       ;; Init the nov buffer.
 765       (set-buffer nov-buffer)
 766       (buffer-disable-undo (current-buffer))
 767       (erase-buffer)
 768       (set-buffer nntp-server-buffer)
 769       ;; Delete the old NOV file.
 770       (when (file-exists-p nov)
 771         (funcall nnmail-delete-file-function nov))
 772       (while files
 773         (unless (file-directory-p
 774                  (setq file (concat dir (int-to-string (car files)))))
 775           (erase-buffer)
 776           (insert-file-contents file)
 777           (narrow-to-region
 778            (goto-char (point-min))
 779            (progn
 780              (search-forward "\n\n" nil t)
 781              (setq chars (- (point-max) (point)))
 782              (max 1 (1- (point)))))
 783           (when (and (not (= 0 chars))  ; none of them empty files...
 784                      (not (= (point-min) (point-max))))
 785             (goto-char (point-min))
 786             (setq nov-line (nnml-make-nov-line chars))
 787             (save-excursion
 788               (set-buffer nov-buffer)
 789               (goto-char (point-max))
 790               (insert (int-to-string (car files)) nov-line)))
 791           (widen))
 792         (setq files (cdr files)))
 793       (save-excursion
 794         (set-buffer nov-buffer)
 795         (write-region 1 (point-max) (expand-file-name nov) nil
 796                       'nomesg)
 797         (kill-buffer (current-buffer))))))
 798
 799 (defun nnml-nov-delete-article (group article)
 800   (save-excursion
 801     (set-buffer (nnml-open-nov group))
 802     (goto-char (point-min))
 803     (if (re-search-forward (concat "^" (int-to-string article) "\t") nil t)
 804         (delete-region (match-beginning 0) (progn (forward-line 1) (point))))
 805     t))
 806
 807 (provide 'nnml)
 808
 809 ;;; nnml.el ends here