git.chise.org Git - elisp/gnus.git-/blob - lisp/nnmh.el

   1 ;;; nnmh.el --- mhspool access for Gnus
   2 ;; Copyright (C) 1995,96,97,98,99 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   5 ;;         Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
   6 ;;         MORIOKA Tomohiko <morioka@jaist.ac.jp>
   7 ;; Keywords: news, mail
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Commentary:
  27
  28 ;; Based on nnspool.el by Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>.
  29 ;; For an overview of what the interface functions do, please see the
  30 ;; Gnus sources.
  31
  32 ;;; Code:
  33
  34 (require 'nnheader)
  35 (require 'nnmail)
  36 (require 'gnus-start)
  37 (require 'nnoo)
  38 (eval-when-compile (require 'cl))
  39
  40 (nnoo-declare nnmh)
  41
  42 (defvoo nnmh-directory message-directory
  43   "*Mail spool directory.")
  44
  45 (defvoo nnmh-get-new-mail t
  46   "*If non-nil, nnmh will check the incoming mail file and split the mail.")
  47
  48 (defvoo nnmh-prepare-save-mail-hook nil
  49   "*Hook run narrowed to an article before saving.")
  50
  51 (defvoo nnmh-be-safe nil
  52   "*If non-nil, nnmh will check all articles to make sure whether they are new or not.")
  53
  54 \f
  55
  56 (defconst nnmh-version "nnmh 1.0"
  57   "nnmh version.")
  58
  59 (defvoo nnmh-current-directory nil
  60   "Current news group directory.")
  61
  62 (defvoo nnmh-status-string "")
  63 (defvoo nnmh-group-alist nil)
  64 (defvoo nnmh-allow-delete-final nil)
  65
  66 \f
  67
  68 ;;; Interface functions.
  69
  70 (nnoo-define-basics nnmh)
  71
  72 (deffoo nnmh-retrieve-headers (articles &optional newsgroup server fetch-old)
  73   (save-excursion
  74     (set-buffer nntp-server-buffer)
  75     (erase-buffer)
  76     (let* ((file nil)
  77            (number (length articles))
  78            (large (and (numberp nnmail-large-newsgroup)
  79                        (> number nnmail-large-newsgroup)))
  80            (count 0)
  81            (pathname-coding-system 'binary)
  82            beg article)
  83       (nnmh-possibly-change-directory newsgroup server)
  84       ;; We don't support fetching by Message-ID.
  85       (if (stringp (car articles))
  86           'headers
  87         (while articles
  88           (when (and (file-exists-p
  89                       (setq file (concat (file-name-as-directory
  90                                           nnmh-current-directory)
  91                                          (int-to-string
  92                                           (setq article (pop articles))))))
  93                      (not (file-directory-p file)))
  94             (insert (format "221 %d Article retrieved.\n" article))
  95             (setq beg (point))
  96             (nnheader-insert-head file)
  97             (goto-char beg)
  98             (if (search-forward "\n\n" nil t)
  99                 (forward-char -1)
 100               (goto-char (point-max))
 101               (insert "\n\n"))
 102             (insert ".\n")
 103             (delete-region (point) (point-max)))
 104           (setq count (1+ count))
 105
 106           (and large
 107                (zerop (% count 20))
 108                (nnheader-message 5 "nnmh: Receiving headers... %d%%"
 109                         (/ (* count 100) number))))
 110
 111         (when large
 112           (nnheader-message 5 "nnmh: Receiving headers...done"))
 113
 114         ;; (nnheader-fold-continuation-lines)
 115         'headers))))
 116
 117 (deffoo nnmh-retrieve-parsed-headers (articles
 118                                       dependencies
 119                                       &optional newsgroup server fetch-old
 120                                       force-new)
 121   (save-excursion
 122     (set-buffer nntp-server-buffer)
 123     (let* ((file nil)
 124            (number (length articles))
 125            (large (and (numberp nnmail-large-newsgroup)
 126                        (> number nnmail-large-newsgroup)))
 127            (count 0)
 128            (pathname-coding-system 'binary)
 129            (case-fold-search t)
 130            ;;beg
 131            article
 132            headers header id end ref lines chars ctype in-reply-to
 133            (cur (current-buffer)))
 134       (nnmh-possibly-change-directory newsgroup server)
 135       ;; We don't support fetching by Message-ID.
 136       (nnheader-retrieve-headers-from-directory
 137        articles nnmh-current-directory dependencies
 138        fetch-old force-new large "nnmh")
 139       )))
 140
 141 (deffoo nnmh-open-server (server &optional defs)
 142   (nnoo-change-server 'nnmh server defs)
 143   (when (not (file-exists-p nnmh-directory))
 144     (condition-case ()
 145         (make-directory nnmh-directory t)
 146       (error t)))
 147   (cond
 148    ((not (file-exists-p nnmh-directory))
 149     (nnmh-close-server)
 150     (nnheader-report 'nnmh "Couldn't create directory: %s" nnmh-directory))
 151    ((not (file-directory-p (file-truename nnmh-directory)))
 152     (nnmh-close-server)
 153     (nnheader-report 'nnmh "Not a directory: %s" nnmh-directory))
 154    (t
 155     (nnheader-report 'nnmh "Opened server %s using directory %s"
 156                      server nnmh-directory)
 157     t)))
 158
 159 (deffoo nnmh-request-article (id &optional newsgroup server buffer)
 160   (nnmh-possibly-change-directory newsgroup server)
 161   (let ((file (if (stringp id)
 162                   nil
 163                 (concat nnmh-current-directory (int-to-string id))))
 164         (pathname-coding-system 'binary)
 165         (nntp-server-buffer (or buffer nntp-server-buffer)))
 166     (and (stringp file)
 167          (file-exists-p file)
 168          (not (file-directory-p file))
 169          (save-excursion (nnmail-find-file file))
 170          (string-to-int (file-name-nondirectory file)))))
 171
 172 (deffoo nnmh-request-group (group &optional server dont-check)
 173   (nnheader-init-server-buffer)
 174   (nnmh-possibly-change-directory group server)
 175   (let ((pathname (nnmail-group-pathname group nnmh-directory))
 176         (pathname-coding-system 'binary)
 177         dir)
 178     (cond
 179      ((not (file-directory-p pathname))
 180       (nnheader-report
 181        'nnmh "Can't select group (no such directory): %s" group))
 182      (t
 183       (setq nnmh-current-directory pathname)
 184       (and nnmh-get-new-mail
 185            nnmh-be-safe
 186            (nnmh-update-gnus-unreads group))
 187       (cond
 188        (dont-check
 189         (nnheader-report 'nnmh "Selected group %s" group)
 190         t)
 191        (t
 192         ;; Re-scan the directory if it's on a foreign system.
 193         (nnheader-re-read-dir pathname)
 194         (setq dir
 195               (sort
 196                (mapcar (lambda (name) (string-to-int name))
 197                        (directory-files pathname nil "^[0-9]+$" t))
 198                '<))
 199           (cond
 200            (dir
 201             (setq nnmh-group-alist
 202                   (delq (assoc group nnmh-group-alist) nnmh-group-alist))
 203             (push (list group (cons (car dir) (car (last dir))))
 204                   nnmh-group-alist)
 205             (nnheader-report 'nnmh "Selected group %s" group)
 206             (nnheader-insert
 207              "211 %d %d %d %s\n" (length dir) (car dir)
 208              (car (last dir)) group))
 209            (t
 210             (nnheader-report 'nnmh "Empty group %s" group)
 211             (nnheader-insert (format "211 0 1 0 %s\n" group))))))))))
 212
 213 (deffoo nnmh-request-scan (&optional group server)
 214   (nnmail-get-new-mail 'nnmh nil nnmh-directory group))
 215
 216 (deffoo nnmh-request-list (&optional server dir)
 217   (nnheader-insert "")
 218   (nnmh-possibly-change-directory nil server)
 219   (let ((pathname-coding-system 'binary)
 220         (nnmh-toplev
 221          (file-truename (or dir (file-name-as-directory nnmh-directory)))))
 222     (nnmh-request-list-1 nnmh-toplev))
 223   (setq nnmh-group-alist (nnmail-get-active))
 224   t)
 225
 226 (defvar nnmh-toplev)
 227 (defun nnmh-request-list-1 (dir)
 228   (setq dir (expand-file-name dir))
 229   ;; Recurse down all directories.
 230   (let ((dirs (and (file-readable-p dir)
 231                    (> (nth 1 (file-attributes (file-chase-links dir))) 2)
 232                    (nnheader-directory-files dir t nil t)))
 233         rdir)
 234     ;; Recurse down directories.
 235     (while (setq rdir (pop dirs))
 236       (when (and (file-directory-p rdir)
 237                  (file-readable-p rdir)
 238                  (not (equal (file-truename rdir)
 239                              (file-truename dir))))
 240         (nnmh-request-list-1 rdir))))
 241   ;; For each directory, generate an active file line.
 242   (unless (string= (expand-file-name nnmh-toplev) dir)
 243     (let ((files (mapcar
 244                   (lambda (name) (string-to-int name))
 245                   (directory-files dir nil "^[0-9]+$" t))))
 246       (when files
 247         (save-excursion
 248           (set-buffer nntp-server-buffer)
 249           (goto-char (point-max))
 250           (insert
 251            (format
 252             "%s %d %d y\n"
 253             (progn
 254               (string-match
 255                (regexp-quote
 256                 (file-truename (file-name-as-directory
 257                                 (expand-file-name nnmh-toplev))))
 258                dir)
 259               (nnheader-replace-chars-in-string
 260                (decode-coding-string (substring dir (match-end 0))
 261                                      nnmail-pathname-coding-system)
 262                ?/ ?.))
 263             (apply 'max files)
 264             (apply 'min files)))))))
 265   t)
 266
 267 (deffoo nnmh-request-newgroups (date &optional server)
 268   (nnmh-request-list server))
 269
 270 (deffoo nnmh-request-expire-articles (articles newsgroup
 271                                                &optional server force)
 272   (nnmh-possibly-change-directory newsgroup server)
 273   (let* ((is-old t)
 274          article rest mod-time)
 275     (nnheader-init-server-buffer)
 276
 277     (while (and articles is-old)
 278       (setq article (concat nnmh-current-directory
 279                             (int-to-string (car articles))))
 280       (when (setq mod-time (nth 5 (file-attributes article)))
 281         (if (and (nnmh-deletable-article-p newsgroup (car articles))
 282                  (setq is-old
 283                        (nnmail-expired-article-p newsgroup mod-time force)))
 284             (progn
 285               (nnheader-message 5 "Deleting article %s in %s..."
 286                                 article newsgroup)
 287               (condition-case ()
 288                   (funcall nnmail-delete-file-function article)
 289                 (file-error
 290                  (nnheader-message 1 "Couldn't delete article %s in %s"
 291                                    article newsgroup)
 292                  (push (car articles) rest))))
 293           (push (car articles) rest)))
 294       (setq articles (cdr articles)))
 295     (nnheader-message 5 "")
 296     (nconc rest articles)))
 297
 298 (deffoo nnmh-close-group (group &optional server)
 299   t)
 300
 301 (deffoo nnmh-request-move-article
 302   (article group server accept-form &optional last)
 303   (let ((buf (get-buffer-create " *nnmh move*"))
 304         result)
 305     (and
 306      (nnmh-deletable-article-p group article)
 307      (nnmh-request-article article group server)
 308      (save-excursion
 309        (set-buffer buf)
 310        (erase-buffer)
 311        (insert-buffer-substring nntp-server-buffer)
 312        (setq result (eval accept-form))
 313        (kill-buffer (current-buffer))
 314        result)
 315      (progn
 316        (nnmh-possibly-change-directory group server)
 317        (condition-case ()
 318            (funcall nnmail-delete-file-function
 319                     (concat nnmh-current-directory (int-to-string article)))
 320          (file-error nil))))
 321     result))
 322
 323 (deffoo nnmh-request-accept-article (group &optional server last noinsert)
 324   (nnmh-possibly-change-directory group server)
 325   (if (and (not (equal group "queue"))
 326            (not (equal group "draft")))
 327       (nnmail-check-syntax))
 328   (when nnmail-cache-accepted-message-ids
 329     (nnmail-cache-insert (nnmail-fetch-field "message-id")))
 330   (nnheader-init-server-buffer)
 331   (prog1
 332       (if (stringp group)
 333           (if noinsert
 334               (nnmh-active-number group)
 335             (car (nnmh-save-mail
 336                   (list (cons group (nnmh-active-number group)))
 337                   noinsert)))
 338         (let ((res (nnmail-article-group 'nnmh-active-number)))
 339           (if (and (null res)
 340                    (yes-or-no-p "Moved to `junk' group; delete article? "))
 341               'junk
 342             (car (nnmh-save-mail res noinsert)))))
 343     (when (and last nnmail-cache-accepted-message-ids)
 344       (nnmail-cache-close))))
 345
 346 (deffoo nnmh-request-replace-article (article group buffer)
 347   (nnmh-possibly-change-directory group)
 348   (save-excursion
 349     (set-buffer buffer)
 350     (nnmh-possibly-create-directory group)
 351     (ignore-errors
 352       (nnmail-write-region
 353        (point-min) (point-max)
 354        (concat nnmh-current-directory (int-to-string article))
 355        nil (if (nnheader-be-verbose 5) nil 'nomesg))
 356       t)))
 357
 358 (deffoo nnmh-request-create-group (group &optional server args)
 359   (nnheader-init-server-buffer)
 360   (unless (assoc group nnmh-group-alist)
 361     (let (active)
 362       (push (list group (setq active (cons 1 0)))
 363             nnmh-group-alist)
 364       (nnmh-possibly-create-directory group)
 365       (nnmh-possibly-change-directory group server)
 366       (let ((articles (mapcar
 367                        (lambda (file)
 368                          (string-to-int file))
 369                        (directory-files
 370                         nnmh-current-directory nil "^[0-9]+$"))))
 371         (when articles
 372           (setcar active (apply 'min articles))
 373           (setcdr active (apply 'max articles))))))
 374   t)
 375
 376 (deffoo nnmh-request-delete-group (group &optional force server)
 377   (nnmh-possibly-change-directory group server)
 378   ;; Delete all articles in GROUP.
 379   (if (not force)
 380       ()                                ; Don't delete the articles.
 381     (let ((articles (directory-files nnmh-current-directory t "^[0-9]+$")))
 382       (while articles
 383         (when (file-writable-p (car articles))
 384           (nnheader-message 5 "Deleting article %s in %s..."
 385                             (car articles) group)
 386           (funcall nnmail-delete-file-function (car articles)))
 387         (setq articles (cdr articles))))
 388     ;; Try to delete the directory itself.
 389     (ignore-errors
 390       (delete-directory nnmh-current-directory)))
 391   ;; Remove the group from all structures.
 392   (setq nnmh-group-alist
 393         (delq (assoc group nnmh-group-alist) nnmh-group-alist)
 394         nnmh-current-directory nil)
 395   t)
 396
 397 (deffoo nnmh-request-rename-group (group new-name &optional server)
 398   (nnmh-possibly-change-directory group server)
 399   (let ((new-dir (nnmail-group-pathname new-name nnmh-directory))
 400         (old-dir (nnmail-group-pathname group nnmh-directory)))
 401     (when (ignore-errors
 402             (make-directory new-dir t)
 403             t)
 404       ;; We move the articles file by file instead of renaming
 405       ;; the directory -- there may be subgroups in this group.
 406       ;; One might be more clever, I guess.
 407       (let ((files (nnheader-article-to-file-alist old-dir)))
 408         (while files
 409           (rename-file
 410            (concat old-dir (cdar files))
 411            (concat new-dir (cdar files)))
 412           (pop files)))
 413       (when (<= (length (directory-files old-dir)) 2)
 414         (ignore-errors
 415           (delete-directory old-dir)))
 416       ;; That went ok, so we change the internal structures.
 417       (let ((entry (assoc group nnmh-group-alist)))
 418         (when entry
 419           (setcar entry new-name))
 420         (setq nnmh-current-directory nil)
 421         t))))
 422
 423 (nnoo-define-skeleton nnmh)
 424
 425 \f
 426 ;;; Internal functions.
 427
 428 (defun nnmh-possibly-change-directory (newsgroup &optional server)
 429   (when (and server
 430              (not (nnmh-server-opened server)))
 431     (nnmh-open-server server))
 432   (when newsgroup
 433     (let ((pathname (nnmail-group-pathname newsgroup nnmh-directory))
 434           (pathname-coding-system 'binary))
 435       (if (file-directory-p pathname)
 436           (setq nnmh-current-directory pathname)
 437         (error "No such newsgroup: %s" newsgroup)))))
 438
 439 (defun nnmh-possibly-create-directory (group)
 440   (let (dir dirs)
 441     (setq dir (nnmail-group-pathname group nnmh-directory))
 442     (while (not (file-directory-p dir))
 443       (push dir dirs)
 444       (setq dir (file-name-directory (directory-file-name dir))))
 445     (while dirs
 446       (when (make-directory (directory-file-name (car dirs)))
 447         (error "Could not create directory %s" (car dirs)))
 448       (nnheader-message 5 "Creating mail directory %s" (car dirs))
 449       (setq dirs (cdr dirs)))))
 450
 451 (defun nnmh-save-mail (group-art &optional noinsert)
 452   "Called narrowed to an article."
 453   (unless noinsert
 454     (nnmail-insert-lines)
 455     (nnmail-insert-xref group-art))
 456   (run-hooks 'nnmail-prepare-save-mail-hook)
 457   (run-hooks 'nnmh-prepare-save-mail-hook)
 458   (goto-char (point-min))
 459   (while (looking-at "From ")
 460     (replace-match "X-From-Line: ")
 461     (forward-line 1))
 462   ;; We save the article in all the newsgroups it belongs in.
 463   (let ((ga group-art)
 464         first)
 465     (while ga
 466       (nnmh-possibly-create-directory (caar ga))
 467       (let ((file (concat (nnmail-group-pathname
 468                            (caar ga) nnmh-directory)
 469                           (int-to-string (cdar ga)))))
 470         (if first
 471             ;; It was already saved, so we just make a hard link.
 472             (funcall nnmail-crosspost-link-function first file t)
 473           ;; Save the article.
 474           (nnmail-write-region (point-min) (point-max) file nil nil)
 475           (setq first file)))
 476       (setq ga (cdr ga))))
 477   group-art)
 478
 479 (defun nnmh-active-number (group)
 480   "Compute the next article number in GROUP."
 481   (let ((active (cadr (assoc group nnmh-group-alist)))
 482         (dir (nnmail-group-pathname group nnmh-directory))
 483         (pathname-coding-system 'binary))
 484     (unless active
 485       ;; The group wasn't known to nnmh, so we just create an active
 486       ;; entry for it.
 487       (setq active (cons 1 0))
 488       (push (list group active) nnmh-group-alist)
 489       (unless (file-exists-p dir)
 490         (gnus-make-directory dir))
 491       ;; Find the highest number in the group.
 492       (let ((files (sort
 493                     (mapcar
 494                      (lambda (f)
 495                        (string-to-int f))
 496                      (directory-files dir nil "^[0-9]+$"))
 497                     '>)))
 498         (when files
 499           (setcdr active (car files)))))
 500     (setcdr active (1+ (cdr active)))
 501     (while (file-exists-p
 502             (concat (nnmail-group-pathname group nnmh-directory)
 503                     (int-to-string (cdr active))))
 504       (setcdr active (1+ (cdr active))))
 505     (cdr active)))
 506
 507 (defun nnmh-update-gnus-unreads (group)
 508   ;; Go through the .nnmh-articles file and compare with the actual
 509   ;; articles in this folder.  The articles that are "new" will be
 510   ;; marked as unread by Gnus.
 511   (let* ((dir nnmh-current-directory)
 512          (files (sort (mapcar (function (lambda (name) (string-to-int name)))
 513                               (directory-files nnmh-current-directory
 514                                                nil "^[0-9]+$" t))
 515                       '<))
 516          (nnmh-file (concat dir ".nnmh-articles"))
 517          new articles)
 518     ;; Load the .nnmh-articles file.
 519     (when (file-exists-p nnmh-file)
 520       (setq articles
 521             (let (nnmh-newsgroup-articles)
 522               (ignore-errors (load nnmh-file nil t t))
 523               nnmh-newsgroup-articles)))
 524     ;; Add all new articles to the `new' list.
 525     (let ((art files))
 526       (while art
 527         (unless (assq (car art) articles)
 528           (push (car art) new))
 529         (setq art (cdr art))))
 530     ;; Remove all deleted articles.
 531     (let ((art articles))
 532       (while art
 533         (unless (memq (caar art) files)
 534           (setq articles (delq (car art) articles)))
 535         (setq art (cdr art))))
 536     ;; Check whether the articles really are the ones that Gnus thinks
 537     ;; they are by looking at the time-stamps.
 538     (let ((arts articles)
 539           art)
 540       (while (setq art (pop arts))
 541         (when (not (equal
 542                     (nth 5 (file-attributes
 543                             (concat dir (int-to-string (car art)))))
 544                     (cdr art)))
 545           (setq articles (delq art articles))
 546           (push (car art) new))))
 547     ;; Go through all the new articles and add them, and their
 548     ;; time-stamps, to the list.
 549     (setq articles
 550           (nconc articles
 551                  (mapcar
 552                   (lambda (art)
 553                     (cons art
 554                           (nth 5 (file-attributes
 555                                   (concat dir (int-to-string art))))))
 556                   new)))
 557     ;; Make Gnus mark all new articles as unread.
 558     (when new
 559       (gnus-make-articles-unread
 560        (gnus-group-prefixed-name group (list 'nnmh ""))
 561        (setq new (sort new '<))))
 562     ;; Sort the article list with highest numbers first.
 563     (setq articles (sort articles (lambda (art1 art2)
 564                                     (> (car art1) (car art2)))))
 565     ;; Finally write this list back to the .nnmh-articles file.
 566     (with-temp-file nnmh-file
 567       (insert ";; Gnus article active file for " group "\n\n")
 568       (insert "(setq nnmh-newsgroup-articles '")
 569       (gnus-prin1 articles)
 570       (insert ")\n"))))
 571
 572 (defun nnmh-deletable-article-p (group article)
 573   "Say whether ARTICLE in GROUP can be deleted."
 574   (let ((path (concat nnmh-current-directory (int-to-string article))))
 575     ;; Writable.
 576     (and (file-writable-p path)
 577          (or
 578           ;; We can never delete the last article in the group.
 579           (not (eq (cdr (nth 1 (assoc group nnmh-group-alist)))
 580                    article))
 581           ;; Well, we can.
 582           nnmh-allow-delete-final))))
 583
 584 (provide 'nnmh)
 585
 586 ;;; nnmh.el ends here