X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fnnml.el;h=c21c2079de8091289472e53d64757dd749acdf72;hp=4e8337e26b2c5fdf9454c89ecd0899d2009358bc;hb=75880493a6a9dad9607a4002d4c6ab2895b110ca;hpb=a77dd35f2d1dc13eb88e5b153d4c03b83f7eb2c7 diff --git a/lisp/nnml.el b/lisp/nnml.el index 4e8337e26..c21c2079d 100644 --- a/lisp/nnml.el +++ b/lisp/nnml.el @@ -1,9 +1,11 @@ ;;; nnml.el --- mail spool access for Gnus -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003 -;; Free Software Foundation, Inc. -;; Author: Simon Josefsson (adding MARKS) -;; Lars Magne Ingebrigtsen +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, +;; 2004, 2005, 2006 Free Software Foundation, Inc. + +;; Authors: Didier Verna (adding compaction) +;; Simon Josefsson (adding MARKS) +;; Lars Magne Ingebrigtsen ;; Masanobu UMEDA ;; Keywords: news, mail @@ -21,8 +23,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: @@ -39,7 +41,8 @@ (eval-when-compile (require 'cl)) (eval-and-compile - (autoload 'gnus-article-unpropagatable-p "gnus-sum")) + (autoload 'gnus-article-unpropagatable-p "gnus-sum") + (autoload 'gnus-backlog-remove-article "gnus-bcklg")) (nnoo-declare nnml) @@ -82,7 +85,18 @@ marks file will be regenerated properly by Gnus.") "If non-nil, inhibit expiry.") (defvoo nnml-use-compressed-files nil - "If non-nil, allow using compressed message files.") + "If non-nil, allow using compressed message files. + +If it is a string, use it as the file extension which specifies +the comression program. You can set it to \".bz2\" if your Emacs +supports auto-compression using the bzip2 program. A value of t +is equivalent to \".gz\".") + +(defvoo nnml-compressed-files-size-threshold 1000 + "Default size threshold for compressed message files. +Message files with bodies larger than that many characters will +be automatically compressed if `nnml-use-compressed-files' is +non-nil.") @@ -212,7 +226,7 @@ marks file will be regenerated properly by Gnus.") (nnheader-report 'nnml "Article %s retrieved" id) ;; We return the article number. (cons (if group-num (car group-num) group) - (string-to-int (file-name-nondirectory path))))))) + (string-to-number (file-name-nondirectory path))))))) (deffoo nnml-request-group (group &optional server dont-check) (let ((file-name-coding-system nnmail-pathname-coding-system)) @@ -335,7 +349,7 @@ marks file will be regenerated properly by Gnus.") (nconc rest articles))) (deffoo nnml-request-move-article - (article group server accept-form &optional last) + (article group server accept-form &optional last move-is-internal) (let ((buf (get-buffer-create " *nnml move*")) result) (nnml-possibly-change-directory group server) @@ -369,7 +383,7 @@ marks file will be regenerated properly by Gnus.") (nnmail-check-syntax) (let (result) (when nnmail-cache-accepted-message-ids - (nnmail-cache-insert (nnmail-fetch-field "message-id") + (nnmail-cache-insert (nnmail-fetch-field "message-id") group (nnmail-fetch-field "subject") (nnmail-fetch-field "from"))) @@ -426,7 +440,7 @@ marks file will be regenerated properly by Gnus.") ;; we should insert it. (This situation should never ;; occur, but one likes to make sure...) (while (and (looking-at "[0-9]+\t") - (< (string-to-int + (< (string-to-number (buffer-substring (match-beginning 0) (match-end 0))) article) @@ -445,10 +459,8 @@ marks file will be regenerated properly by Gnus.") nnml-current-directory t (concat nnheader-numerical-short-files "\\|" (regexp-quote nnml-nov-file-name) "$" - "\\|" (regexp-quote nnml-marks-file-name) "$"))) - article) - (while articles - (setq article (pop articles)) + "\\|" (regexp-quote nnml-marks-file-name) "$")))) + (dolist (article articles) (when (file-writable-p article) (nnheader-message 5 "Deleting article %s in %s..." article group) (funcall nnmail-delete-file-function article)))) @@ -473,12 +485,10 @@ marks file will be regenerated properly by Gnus.") ;; We move the articles file by file instead of renaming ;; the directory -- there may be subgroups in this group. ;; One might be more clever, I guess. - (let ((files (nnheader-article-to-file-alist old-dir))) - (while files - (rename-file - (concat old-dir (cdar files)) - (concat new-dir (cdar files))) - (pop files))) + (dolist (file (nnheader-article-to-file-alist old-dir)) + (rename-file + (concat old-dir (cdr file)) + (concat new-dir (cdr file)))) ;; Move .overview file. (let ((overview (concat old-dir nnml-nov-file-name))) (when (file-exists-p overview) @@ -625,8 +635,10 @@ marks file will be regenerated properly by Gnus.") (setq chars (nnmail-insert-lines)) (setq extension (and nnml-use-compressed-files - (> chars 1000) - ".gz")) + (> chars nnml-compressed-files-size-threshold) + (if (stringp nnml-use-compressed-files) + nnml-use-compressed-files + ".gz"))) (nnmail-insert-xref group-art) (run-hooks 'nnmail-prepare-save-mail-hook) (run-hooks 'nnml-prepare-save-mail-hook) @@ -770,12 +782,10 @@ marks file will be regenerated properly by Gnus.") (unless (member (file-truename dir) seen) (push (file-truename dir) seen) ;; We descend recursively - (let ((dirs (directory-files dir t nil t)) - dir) - (while (setq dir (pop dirs)) - (when (and (not (string-match "^\\." (file-name-nondirectory dir))) - (file-directory-p dir)) - (nnml-generate-nov-databases-1 dir seen)))) + (dolist (dir (directory-files dir t nil t)) + (when (and (not (string-match "^\\." (file-name-nondirectory dir))) + (file-directory-p dir)) + (nnml-generate-nov-databases-1 dir seen))) ;; Do this directory. (let ((files (sort (nnheader-article-to-file-alist dir) 'car-less-than-car))) @@ -802,9 +812,7 @@ marks file will be regenerated properly by Gnus.") (push (list group (cons (or (caar files) (1+ last)) (max last - (or (let ((f files)) - (while (cdr f) (setq f (cdr f))) - (caar f)) + (or (caar (last files)) 0)))) nnml-group-alist))) @@ -923,7 +931,7 @@ Use the nov database for the current group if available." (let ((range (nth 0 action)) (what (nth 1 action)) (marks (nth 2 action))) - (assert (or (eq what 'add) (eq what 'del)) t + (assert (or (eq what 'add) (eq what 'del)) nil "Unknown request-set-mark action: %s" what) (dolist (mark marks) (setq nnml-marks (gnus-update-alist-soft @@ -941,16 +949,16 @@ Use the nov database for the current group if available." (nnheader-message 8 "Updating marks for %s..." group) (nnml-open-marks group server) ;; Update info using `nnml-marks'. - (mapcar (lambda (pred) - (unless (memq (cdr pred) gnus-article-unpropagated-mark-lists) - (gnus-info-set-marks - info - (gnus-update-alist-soft - (cdr pred) - (cdr (assq (cdr pred) nnml-marks)) - (gnus-info-marks info)) - t))) - gnus-article-mark-lists) + (mapc (lambda (pred) + (unless (memq (cdr pred) gnus-article-unpropagated-mark-lists) + (gnus-info-set-marks + info + (gnus-update-alist-soft + (cdr pred) + (cdr (assq (cdr pred) nnml-marks)) + (gnus-info-marks info)) + t))) + gnus-article-mark-lists) (let ((seen (cdr (assq 'read nnml-marks)))) (gnus-info-set-read info (if (and (integerp (car seen)) @@ -984,7 +992,7 @@ Use the nov database for the current group if available." nnml-marks-modtime)) (error (or (gnus-yes-or-no-p (format "Could not write to %s (%s). Continue? " file err)) - (error "Cannot write to %s (%s)" err)))))) + (error "Cannot write to %s (%s)" file err)))))) (defun nnml-open-marks (group server) (let ((file (expand-file-name @@ -1016,6 +1024,192 @@ Use the nov database for the current group if available." (nnml-save-marks group server) (nnheader-message 7 "Bootstrapping marks for %s...done" group))))) + +;;; +;;; Group and server compaction. -- dvl +;;; + +;; #### FIXME: this function handles self Xref: entry correctly, but I don't +;; #### know how to handle external cross-references. I actually don't know if +;; #### this is handled correctly elsewhere. For instance, what happens if you +;; #### move all articles to a new group (that's what people do for manual +;; #### compaction) ? + +;; #### NOTE: the function below handles the article backlog. This is +;; #### conceptually the wrong place to do it because the backend is at a +;; #### lower level. However, this is the only place where we have the needed +;; #### information to do the job. Ideally, this function should not handle +;; #### the backlog by itself, but return a list of moved groups / articles to +;; #### the caller. This will become important to avoid code duplication when +;; #### other backends get a compaction feature. Also, note that invalidating +;; #### the "original article buffer" is already done at an upper level. + +(defun nnml-request-compact-group (group &optional server save) + (nnml-possibly-change-directory group server) + (unless nnml-article-file-alist + (setq nnml-article-file-alist + (sort (nnml-current-group-article-to-file-alist) + 'car-less-than-car))) + (if (not nnml-article-file-alist) + ;; The group is empty: do nothing but return t + t + ;; The group is not empty: + (let* ((group-full-name + (gnus-group-prefixed-name + group + (gnus-server-to-method (format "nnml:%s" server)))) + (info (gnus-get-info group-full-name)) + (new-number 1) + compacted) + (let ((articles nnml-article-file-alist) + article) + (while (setq article (pop articles)) + (let ((old-number (car article))) + (when (> old-number new-number) + ;; There is a gap here: + (let ((old-number-string (int-to-string old-number)) + (new-number-string (int-to-string new-number))) + (setq compacted t) + ;; #### NOTE: `nnml-article-to-file' calls + ;; #### `nnml-update-file-alist' (which in turn calls + ;; #### `nnml-current-group-article-to-file-alist', which + ;; #### might use the NOV database). This might turn out to be + ;; #### inefficient. In that case, we will do the work + ;; #### manually. + ;; 1/ Move the article to a new file: + (let* ((oldfile (nnml-article-to-file old-number)) + (newfile + (gnus-replace-in-string + oldfile (concat "\\(" + old-number-string + "\\)\\(\\(\\.gz\\)?\\)$") + (concat new-number-string "\\2")))) + (with-current-buffer nntp-server-buffer + (nnmail-find-file oldfile) + ;; Update the Xref header in the article itself: + (when (and (re-search-forward "^Xref: [^ ]+ " nil t) + (re-search-forward + (concat "\\<" + (regexp-quote + (concat group ":" old-number-string)) + "\\>") + (point-at-eol) t)) + (replace-match + (concat group ":" new-number-string))) + ;; Save to the new file: + (nnmail-write-region (point-min) (point-max) newfile)) + (funcall nnmail-delete-file-function oldfile)) + ;; 2/ Update all marks for this article: + ;; #### NOTE: it is possible that the new article number + ;; #### already belongs to a range, whereas the corresponding + ;; #### article doesn't exist (for example, if you delete an + ;; #### article). For that reason, it is important to update + ;; #### the ranges (meaning remove inexistant articles) before + ;; #### doing anything on them. + ;; 2 a/ read articles: + (let ((read (gnus-info-read info))) + (setq read (gnus-remove-from-range read (list new-number))) + (when (gnus-member-of-range old-number read) + (setq read (gnus-remove-from-range read (list old-number))) + (setq read (gnus-add-to-range read (list new-number)))) + (gnus-info-set-read info read)) + ;; 2 b/ marked articles: + (let ((oldmarks (gnus-info-marks info)) + mark newmarks) + (while (setq mark (pop oldmarks)) + (setcdr mark (gnus-remove-from-range (cdr mark) + (list new-number))) + (when (gnus-member-of-range old-number (cdr mark)) + (setcdr mark (gnus-remove-from-range (cdr mark) + (list old-number))) + (setcdr mark (gnus-add-to-range (cdr mark) + (list new-number)))) + (push mark newmarks)) + (gnus-info-set-marks info newmarks)) + ;; 3/ Update the NOV entry for this article: + (unless nnml-nov-is-evil + (save-excursion + (set-buffer (nnml-open-nov group)) + (when (nnheader-find-nov-line old-number) + ;; Replace the article number: + (looking-at old-number-string) + (replace-match new-number-string nil t) + ;; Update the Xref header: + (when (re-search-forward + (concat "\\(Xref:[^\t\n]* \\)\\<" + (regexp-quote + (concat group ":" old-number-string)) + "\\>") + (point-at-eol) t) + (replace-match + (concat "\\1" group ":" new-number-string)))))) + ;; 4/ Possibly remove the article from the backlog: + (when gnus-keep-backlog + ;; #### NOTE: instead of removing the article, we could + ;; #### modify the backlog to reflect the numbering change, + ;; #### but I don't think it's worth it. + (gnus-backlog-remove-article group-full-name old-number) + (gnus-backlog-remove-article group-full-name new-number)))) + (setq new-number (1+ new-number))))) + (if (not compacted) + ;; No compaction had to be done: + t + ;; Some articles have actually been renamed: + ;; 1/ Rebuild active information: + (let ((entry (assoc group nnml-group-alist)) + (active (cons 1 (1- new-number)))) + (setq nnml-group-alist (delq entry nnml-group-alist)) + (push (list group active) nnml-group-alist) + ;; Update the active hashtable to let the *Group* buffer display + ;; up-to-date lines. I don't think that either gnus-newsrc-hashtb or + ;; gnus-newwrc-alist are out of date, since all we did is to modify + ;; the info of the group internally. + (gnus-set-active group-full-name active)) + ;; 1 bis/ + ;; #### NOTE: normally, we should save the overview (NOV) file + ;; #### here, just like we save the marks file. However, there is no + ;; #### such function as nnml-save-nov for a single group. Only for + ;; #### all groups. Gnus inconsistency is getting worse every day... + ;; 2/ Rebuild marks file: + (unless nnml-marks-is-evil + ;; #### NOTE: this constant use of global variables everywhere is + ;; #### truly disgusting. Gnus really needs a *major* cleanup. + (setq nnml-marks (gnus-info-marks info)) + (push (cons 'read (gnus-info-read info)) nnml-marks) + (dolist (el gnus-article-unpropagated-mark-lists) + (setq nnml-marks (gnus-remassoc el nnml-marks))) + (nnml-save-marks group server)) + ;; 3/ Save everything if this was not part of a bigger operation: + (if (not save) + ;; Nothing to save (yet): + t + ;; Something to save: + ;; a/ Save the NOV databases: + ;; #### NOTE: this should be done directory per directory in 1bis + ;; #### above. See comment there. + (nnml-save-nov) + ;; b/ Save the active file: + (nnmail-save-active nnml-group-alist nnml-active-file) + t))))) + +(defun nnml-request-compact (&optional server) + "Request compaction of all SERVER nnml groups." + (interactive (list (or (nnoo-current-server 'nnml) ""))) + (nnmail-activate 'nnml) + (unless (nnml-server-opened server) + (nnml-open-server server)) + (setq nnml-directory (expand-file-name nnml-directory)) + (let* ((groups (gnus-groups-from-server + (gnus-server-to-method (format "nnml:%s" server)))) + (first (pop groups)) + group) + (when first + (while (setq group (pop groups)) + (nnml-request-compact-group (gnus-group-real-name group) server)) + (nnml-request-compact-group (gnus-group-real-name first) server t)))) + + (provide 'nnml) +;;; arch-tag: 52c97dc3-9735-45de-b439-9e4d23b52004 ;;; nnml.el ends here