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

   1 ;;; nnml.el --- mail spool access for Gnus
   2
   3 ;; Copyright (C) 1995-2011 Free Software
   4 ;;   Foundation, Inc.
   5
   6 ;; Authors: Didier Verna <didier@xemacs.org> (adding compaction)
   7 ;;      Simon Josefsson <simon@josefsson.org> (adding MARKS)
   8 ;;      Lars Magne Ingebrigtsen <larsi@gnus.org>
   9 ;;      Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
  10 ;; Keywords: news, mail
  11
  12 ;; This file is part of GNU Emacs.
  13
  14 ;; GNU Emacs is free software: you can redistribute it and/or modify
  15 ;; it under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation, either version 3 of the License, or
  17 ;; (at your option) any later version.
  18
  19 ;; GNU Emacs is distributed in the hope that it will be useful,
  20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;; GNU General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  26
  27 ;;; Commentary:
  28
  29 ;; Based on nnspool.el by Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>.
  30 ;; For an overview of what the interface functions do, please see the
  31 ;; Gnus sources.
  32
  33 ;;; Code:
  34
  35 (require 'gnus)
  36 (require 'nnheader)
  37 (require 'nnmail)
  38 (require 'nnoo)
  39 (eval-when-compile (require 'cl))
  40
  41 ;; FIXME first is unused in this file.
  42 (autoload 'gnus-article-unpropagatable-p "gnus-sum")
  43 (autoload 'gnus-backlog-remove-article "gnus-bcklg")
  44
  45 (nnoo-declare nnml)
  46
  47 (defvoo nnml-directory message-directory
  48   "Spool directory for the nnml mail backend.")
  49
  50 (defvoo nnml-active-file
  51     (expand-file-name "active" nnml-directory)
  52   "Mail active file.")
  53
  54 (defvoo nnml-newsgroups-file
  55     (expand-file-name "newsgroups" nnml-directory)
  56   "Mail newsgroups description file.")
  57
  58 (defvoo nnml-get-new-mail t
  59   "If non-nil, nnml will check the incoming mail file and split the mail.")
  60
  61 (defvoo nnml-nov-is-evil nil
  62   "If non-nil, Gnus will never generate and use nov databases for mail spools.
  63 Using nov databases will speed up header fetching considerably.
  64 This variable shouldn't be flipped much.  If you have, for some reason,
  65 set this to t, and want to set it to nil again, you should always run
  66 the `nnml-generate-nov-databases' command.  The function will go
  67 through all nnml directories and generate nov databases for them
  68 all.  This may very well take some time.")
  69
  70 (defvoo nnml-marks-is-evil nil
  71   "If non-nil, Gnus will never generate and use marks file for mail spools.
  72 Using marks files makes it possible to backup and restore mail groups
  73 separately from `.newsrc.eld'.  If you have, for some reason, set this
  74 to t, and want to set it to nil again, you should always remove the
  75 corresponding marks file (usually named `.marks' in the nnml group
  76 directory, but see `nnml-marks-file-name') for the group.  Then the
  77 marks file will be regenerated properly by Gnus.")
  78
  79 (defvoo nnml-prepare-save-mail-hook nil
  80   "Hook run narrowed to an article before saving.")
  81
  82 (defvoo nnml-inhibit-expiry nil
  83   "If non-nil, inhibit expiry.")
  84
  85 (defvoo nnml-use-compressed-files nil
  86   "If non-nil, allow using compressed message files.
  87
  88 If it is a string, use it as the file extension which specifies
  89 the compression program.  You can set it to \".bz2\" if your Emacs
  90 supports auto-compression using the bzip2 program.  A value of t
  91 is equivalent to \".gz\".")
  92
  93 (defvoo nnml-compressed-files-size-threshold 1000
  94   "Default size threshold for compressed message files.
  95 Message files with bodies larger than that many characters will
  96 be automatically compressed if `nnml-use-compressed-files' is
  97 non-nil.")
  98
  99 \f
 100
 101 (defconst nnml-version "nnml 1.0"
 102   "nnml version.")
 103
 104 (defvoo nnml-nov-file-name ".overview")
 105 (defvoo nnml-marks-file-name ".marks")
 106
 107 (defvoo nnml-current-directory nil)
 108 (defvoo nnml-current-group nil)
 109 (defvoo nnml-status-string "")
 110 (defvoo nnml-nov-buffer-alist nil)
 111 (defvoo nnml-group-alist nil)
 112 (defvoo nnml-active-timestamp nil)
 113 (defvoo nnml-article-file-alist nil)
 114
 115 (defvoo nnml-generate-active-function 'nnml-generate-active-info)
 116
 117 (defvar nnml-nov-buffer-file-name nil)
 118
 119 (defvoo nnml-file-coding-system nnmail-file-coding-system)
 120
 121 (defvoo nnml-marks nil)
 122
 123 (defvar nnml-marks-modtime (gnus-make-hashtable))
 124
 125 \f
 126 ;;; Interface functions.
 127
 128 (nnoo-define-basics nnml)
 129
 130 (eval-when-compile
 131   (defsubst nnml-group-name-charset (group server-or-method)
 132     (gnus-group-name-charset
 133      (if (stringp server-or-method)
 134          (gnus-server-to-method
 135           (if (string-match "\\+" server-or-method)
 136               (concat (substring server-or-method 0 (match-beginning 0))
 137                       ":" (substring server-or-method (match-end 0)))
 138             (concat "nnml:" server-or-method)))
 139        (or server-or-method gnus-command-method '(nnml "")))
 140      group)))
 141
 142 (defun nnml-decoded-group-name (group &optional server-or-method)
 143   "Return a decoded group name of GROUP on SERVER-OR-METHOD."
 144   (if nnmail-group-names-not-encoded-p
 145       group
 146     (mm-decode-coding-string
 147      group
 148      (nnml-group-name-charset group server-or-method))))
 149
 150 (defun nnml-encoded-group-name (group &optional server-or-method)
 151   "Return an encoded group name of GROUP on SERVER-OR-METHOD."
 152   (mm-encode-coding-string
 153    group
 154    (nnml-group-name-charset group server-or-method)))
 155
 156 (defun nnml-group-pathname (group &optional file server)
 157   "Return an absolute file name of FILE for GROUP on SERVER."
 158   (nnmail-group-pathname (inline (nnml-decoded-group-name group server))
 159                          nnml-directory file))
 160
 161 (deffoo nnml-retrieve-headers (sequence &optional group server fetch-old)
 162   (when (nnml-possibly-change-directory group server)
 163     (with-current-buffer nntp-server-buffer
 164       (erase-buffer)
 165       (let* ((file nil)
 166              (number (length sequence))
 167              (count 0)
 168              (file-name-coding-system nnmail-pathname-coding-system)
 169              beg article)
 170         (if (stringp (car sequence))
 171             'headers
 172           (if (nnml-retrieve-headers-with-nov sequence fetch-old)
 173               'nov
 174             (while sequence
 175               (setq article (car sequence))
 176               (setq file (nnml-article-to-file article))
 177               (when (and file
 178                          (file-exists-p file)
 179                          (not (file-directory-p file)))
 180                 (insert (format "221 %d Article retrieved.\n" article))
 181                 (setq beg (point))
 182                 (nnheader-insert-head file)
 183                 (goto-char beg)
 184                 (if (re-search-forward "\n\r?\n" nil t)
 185                     (forward-char -1)
 186                   (goto-char (point-max))
 187                   (insert "\n\n"))
 188                 (insert ".\n")
 189                 (delete-region (point) (point-max)))
 190               (setq sequence (cdr sequence))
 191               (setq count (1+ count))
 192               (and (numberp nnmail-large-newsgroup)
 193                    (> number nnmail-large-newsgroup)
 194                    (zerop (% count 20))
 195                    (nnheader-message 6 "nnml: Receiving headers... %d%%"
 196                                      (/ (* count 100) number))))
 197
 198             (and (numberp nnmail-large-newsgroup)
 199                  (> number nnmail-large-newsgroup)
 200                  (nnheader-message 6 "nnml: Receiving headers...done"))
 201
 202             (nnheader-fold-continuation-lines)
 203             'headers))))))
 204
 205 (deffoo nnml-open-server (server &optional defs)
 206   (nnoo-change-server 'nnml server defs)
 207   (when (not (file-exists-p nnml-directory))
 208     (ignore-errors (make-directory nnml-directory t)))
 209   (cond
 210    ((not (file-exists-p nnml-directory))
 211     (nnml-close-server)
 212     (nnheader-report 'nnml "Couldn't create directory: %s" nnml-directory))
 213    ((not (file-directory-p (file-truename nnml-directory)))
 214     (nnml-close-server)
 215     (nnheader-report 'nnml "Not a directory: %s" nnml-directory))
 216    (t
 217     (nnheader-report 'nnml "Opened server %s using directory %s"
 218                      server nnml-directory)
 219     t)))
 220
 221 (deffoo nnml-request-regenerate (server)
 222   (nnml-possibly-change-directory nil server)
 223   (nnml-generate-nov-databases server)
 224   t)
 225
 226 (deffoo nnml-request-article (id &optional group server buffer)
 227   (nnml-possibly-change-directory group server)
 228   (let* ((nntp-server-buffer (or buffer nntp-server-buffer))
 229          (file-name-coding-system nnmail-pathname-coding-system)
 230          path gpath group-num)
 231     (if (stringp id)
 232         (when (and (setq group-num (nnml-find-group-number id server))
 233                    (cdr
 234                     (assq (cdr group-num)
 235                           (nnheader-article-to-file-alist
 236                            (setq gpath (nnml-group-pathname (car group-num)
 237                                                             nil server))))))
 238           (nnml-update-file-alist)
 239           (setq path (concat gpath (if nnml-use-compressed-files
 240                                        (cdr (assq (cdr group-num)
 241                                                   nnml-article-file-alist))
 242                                      (number-to-string (cdr group-num))))))
 243       (setq path (nnml-article-to-file id)))
 244     (cond
 245      ((not path)
 246       (nnheader-report 'nnml "No such article: %s" id))
 247      ((not (file-exists-p path))
 248       (nnheader-report 'nnml "No such file: %s" path))
 249      ((file-directory-p path)
 250       (nnheader-report 'nnml "File is a directory: %s" path))
 251      ((not (save-excursion (let ((nnmail-file-coding-system
 252                                   nnml-file-coding-system))
 253                              (nnmail-find-file path))))
 254       (nnheader-report 'nnml "Couldn't read file: %s" path))
 255      (t
 256       (nnheader-report 'nnml "Article %s retrieved" id)
 257       ;; We return the article number.
 258       (cons (if group-num (car group-num) group)
 259             (string-to-number (file-name-nondirectory path)))))))
 260
 261 (deffoo nnml-request-group (group &optional server dont-check info)
 262   (let ((file-name-coding-system nnmail-pathname-coding-system)
 263         (decoded (nnml-decoded-group-name group server)))
 264     (cond
 265      ((not (nnml-possibly-change-directory group server))
 266       (nnheader-report 'nnml "Invalid group (no such directory)"))
 267      ((not (file-exists-p nnml-current-directory))
 268       (nnheader-report 'nnml "Directory %s does not exist"
 269                        nnml-current-directory))
 270      ((not (file-directory-p nnml-current-directory))
 271       (nnheader-report 'nnml "%s is not a directory" nnml-current-directory))
 272      (dont-check
 273       (nnheader-report 'nnml "Group %s selected" decoded)
 274       t)
 275      (t
 276       (nnheader-re-read-dir nnml-current-directory)
 277       (nnmail-activate 'nnml)
 278       (let ((active (nth 1 (assoc group nnml-group-alist))))
 279         (if (not active)
 280             (nnheader-report 'nnml "No such group: %s" decoded)
 281           (nnheader-report 'nnml "Selected group %s" decoded)
 282           (nnheader-insert "211 %d %d %d %s\n"
 283                            (max (1+ (- (cdr active) (car active))) 0)
 284                            (car active) (cdr active) group)))))))
 285
 286 (deffoo nnml-request-scan (&optional group server)
 287   (setq nnml-article-file-alist nil)
 288   (nnml-possibly-change-directory group server)
 289   (nnmail-get-new-mail 'nnml 'nnml-save-incremental-nov nnml-directory group))
 290
 291 (deffoo nnml-close-group (group &optional server)
 292   (setq nnml-article-file-alist nil)
 293   t)
 294
 295 (deffoo nnml-request-create-group (group &optional server args)
 296   (nnml-possibly-change-directory nil server)
 297   (nnmail-activate 'nnml)
 298   (cond
 299    ((let ((file (directory-file-name (nnml-group-pathname group nil server)))
 300           (file-name-coding-system nnmail-pathname-coding-system))
 301       (and (file-exists-p file)
 302            (not (file-directory-p file))))
 303     (nnheader-report 'nnml "%s is a file"
 304                      (directory-file-name (nnml-group-pathname group
 305                                                                nil server))))
 306    ((assoc group nnml-group-alist)
 307     t)
 308    (t
 309     (let (active)
 310       (push (list group (setq active (cons 1 0)))
 311             nnml-group-alist)
 312       (nnml-possibly-create-directory group server)
 313       (nnml-possibly-change-directory group server)
 314       (let* ((file-name-coding-system nnmail-pathname-coding-system)
 315              (articles (nnml-directory-articles nnml-current-directory)))
 316         (when articles
 317           (setcar active (apply 'min articles))
 318           (setcdr active (apply 'max articles))))
 319       (nnmail-save-active nnml-group-alist nnml-active-file)
 320       t))))
 321
 322 (deffoo nnml-request-list (&optional server)
 323   (save-excursion
 324     (let ((nnmail-file-coding-system nnmail-active-file-coding-system)
 325           (file-name-coding-system nnmail-pathname-coding-system))
 326       (nnmail-find-file nnml-active-file))
 327     (setq nnml-group-alist (nnmail-get-active))
 328     t))
 329
 330 (deffoo nnml-request-newgroups (date &optional server)
 331   (nnml-request-list server))
 332
 333 (deffoo nnml-request-list-newsgroups (&optional server)
 334   (save-excursion
 335     (nnmail-find-file nnml-newsgroups-file)))
 336
 337 (deffoo nnml-request-expire-articles (articles group &optional server force)
 338   (nnml-possibly-change-directory group server)
 339   (let* ((file-name-coding-system nnmail-pathname-coding-system)
 340          (active-articles
 341           (nnml-directory-articles nnml-current-directory))
 342          (is-old t)
 343          (decoded (nnml-decoded-group-name group server))
 344          article rest mod-time number target)
 345     (nnmail-activate 'nnml)
 346
 347     (setq active-articles (sort active-articles '<))
 348     ;; Articles not listed in active-articles are already gone,
 349     ;; so don't try to expire them.
 350     (setq articles (gnus-sorted-intersection articles active-articles))
 351
 352     (while (and articles is-old)
 353       (if (and (setq article (nnml-article-to-file
 354                               (setq number (pop articles))))
 355                (setq mod-time (nth 5 (file-attributes article)))
 356                (nnml-deletable-article-p group number)
 357                (setq is-old (nnmail-expired-article-p group mod-time force
 358                                                       nnml-inhibit-expiry)))
 359           (progn
 360             ;; Allow a special target group.
 361             (setq target nnmail-expiry-target)
 362             (unless (eq target 'delete)
 363               (with-temp-buffer
 364                 (nnml-request-article number group server (current-buffer))
 365                 (let (nnml-current-directory
 366                       nnml-current-group
 367                       nnml-article-file-alist)
 368                   (when (functionp target)
 369                     (setq target (funcall target group)))
 370                   (when (and target (not (eq target 'delete)))
 371                     (if (or (gnus-request-group target)
 372                             (gnus-request-create-group target))
 373                         (nnmail-expiry-target-group target group)
 374                       (setq target nil)))))
 375               ;; Maybe directory is changed during nnmail-expiry-target-group.
 376               (nnml-possibly-change-directory group server))
 377             (if target
 378                 (progn
 379                   (nnheader-message 5 "Deleting article %s in %s"
 380                                     number decoded)
 381                   (condition-case ()
 382                       (funcall nnmail-delete-file-function article)
 383                     (file-error
 384                      (push number rest)))
 385                   (setq active-articles (delq number active-articles))
 386                   (nnml-nov-delete-article group number))
 387               (push number rest)))
 388         (push number rest)))
 389     (let ((active (nth 1 (assoc group nnml-group-alist))))
 390       (when active
 391         (setcar active (or (and active-articles
 392                                 (apply 'min active-articles))
 393                            (1+ (cdr active)))))
 394       (nnmail-save-active nnml-group-alist nnml-active-file))
 395     (nnml-save-nov)
 396     (nconc rest articles)))
 397
 398 (deffoo nnml-request-move-article
 399     (article group server accept-form &optional last move-is-internal)
 400   (let ((buf (get-buffer-create " *nnml move*"))
 401         (file-name-coding-system nnmail-pathname-coding-system)
 402         result)
 403     (nnml-possibly-change-directory group server)
 404     (nnml-update-file-alist)
 405     (and
 406      (nnml-deletable-article-p group article)
 407      (nnml-request-article article&