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