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

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