Synch to No Gnus 200509191333.

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index d319984..552b5ac 100644 (file)
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,22 @@
+2005-09-19  Didier Verna  <didier@xemacs.org>
+
+       The nnml compaction feature:
+       * nnml.el (nnml-request-compact-group): New function.
+       * nnml.el (nnml-request-compact): New function.
+       * gnus-int.el (gnus-request-compact-group): New function.
+       * gnus-int.el (gnus-request-compact): New function.
+       * gnus-group.el (gnus-group-compact-group): New function.
+       * gnus-group.el (gnus-group-group-map): Bind it to 'G z'.
+       * gnus-group.el (gnus-group-make-menu-bar): Add an entry for it.
+       * gnus-srvr.el (gnus-server-compact-server): New function.
+       * gnus-srvr.el (gnus-server-mode-map): Bind it to 'z'.
+       * gnus-srvr.el (gnus-server-make-menu-bar): Add an entry for it.
+
+2005-09-18  D Goel  <deego@gnufans.org>
+
+       * sieve.el (sieve-help): Fix `message' call: first arg should be a
+       format spec.
+
 2005-09-16  Katsumi Yamaoka  <yamaoka@jpl.org>
 
        * gnus.el (gnus-group-startup-message): Bind image-load-path.

diff --git a/lisp/gnus-group.el b/lisp/gnus-group.el
index 580a98f..a34987d 100644 (file)
--- a/lisp/gnus-group.el
+++ b/lisp/gnus-group.el
@@ -667,6 +667,7 @@ simple manner.")
   "r" gnus-group-rename-group
   "R" gnus-group-make-rss-group
   "c" gnus-group-customize
+  "z" gnus-group-compact-group
   "x" gnus-group-nnimap-expunge
   "\177" gnus-group-delete-group
   [delete] gnus-group-delete-group)
@@ -845,6 +846,8 @@ simple manner.")
        (gnus-group-group-name)]
        ["Select quick" gnus-group-quick-select-group (gnus-group-group-name)]
        ["Customize" gnus-group-customize (gnus-group-group-name)]
+       ["Compact" gnus-group-compact-group
+       :active (gnus-group-group-name)]
        ("Edit"
        ["Parameters" gnus-group-edit-group-parameters
         :included (not (gnus-topic-mode-p))
@@ -4385,6 +4388,32 @@ This command may read the active file."
        (gnus-add-marked-articles
         group 'expire (list article))))))
 
+
+;;;
+;;; Group compaction
+;;;
+
+(defun gnus-group-compact-group (group)
+  "Conpact the current group.
+Compaction means removing gaps between article numbers.  Hence, this
+operation is only meaningful for back ends using one file per article
+\(e.g. nnml)."
+  (interactive (list (gnus-group-group-name)))
+  (unless group
+    (error "No group to compact"))
+  (unless (gnus-check-backend-function 'request-compact-group group)
+    (error "This back end does not support group compaction"))
+  (let ((group-decoded (gnus-group-decoded-name group)))
+    (gnus-message 6 "\
+Compacting group %s... (this may take a long time)"
+                 group-decoded)
+    (prog1
+       (if (not (gnus-request-compact-group group))
+           (gnus-error 3 "Couldn't compact group %s" group-decoded)
+         (gnus-message 6 "Compacting group %s...done" group-decoded)
+         t)
+      (gnus-group-update-group-line))))
+
 (provide 'gnus-group)
 
 ;;; gnus-group.el ends here

diff --git a/lisp/gnus-int.el b/lisp/gnus-int.el
index da07a85..01cb632 100644 (file)
--- a/lisp/gnus-int.el
+++ b/lisp/gnus-int.el
@@ -334,6 +334,23 @@ name.  The method this group uses will be queried."
   (funcall (gnus-get-function gnus-command-method 'request-regenerate)
           (nth 1 gnus-command-method)))
 
+(defun gnus-request-compact-group (group)
+  (let* ((method (gnus-find-method-for-group group))
+        (gnus-command-method method)
+        (result
+         (funcall (gnus-get-function gnus-command-method
+                                     'request-compact-group)
+                  (gnus-group-real-name group)
+                  (nth 1 gnus-command-method) t)))
+    result))
+
+(defun gnus-request-compact (gnus-command-method)
+  "Request groups compaction  from GNUS-COMMAND-METHOD."
+  (when (stringp gnus-command-method)
+    (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
+  (funcall (gnus-get-function gnus-command-method 'request-compact)
+          (nth 1 gnus-command-method)))
+
 (defun gnus-request-group (group &optional dont-check gnus-command-method)
   "Request GROUP.  If DONT-CHECK, no information is required."
   (let ((gnus-command-method

diff --git a/lisp/gnus-srvr.el b/lisp/gnus-srvr.el
index 0537fc5..68362ad 100644 (file)
--- a/lisp/gnus-srvr.el
+++ b/lisp/gnus-srvr.el
@@ -116,6 +116,7 @@ If nil, a faster, but more primitive, buffer is used instead."
        ["Copy" gnus-server-copy-server t]
        ["Edit" gnus-server-edit-server t]
        ["Regenerate" gnus-server-regenerate-server t]
+       ["Compact" gnus-server-compact-server t]
        ["Exit" gnus-server-exit t]))
 
     (easy-menu-define
@@ -165,6 +166,8 @@ If nil, a faster, but more primitive, buffer is used instead."
 
     "g" gnus-server-regenerate-server
 
+    "z" gnus-server-compact-server
+
     "\C-c\C-i" gnus-info-find-node
     "\C-c\C-b" gnus-bug))
 
@@ -1012,6 +1015,33 @@ If NUMBER, fetch this number of articles."
        (gnus-message 5 "Requesting regeneration of %s...done" server)
       (gnus-message 5 "Couldn't regenerate %s" server))))
 
+
+;;;
+;;; Server compaction
+;;;
+
+;; #### FIXME: this function currently fails to update the Group buffer's
+;; #### FIXME: appearance. -- dvl
+(defun gnus-server-compact-server ()
+  "Issue a command to the server to compact all its groups."
+  (interactive)
+  (let ((server (gnus-server-server-name)))
+    (unless server
+      (error "No server on the current line"))
+    (condition-case ()
+       (gnus-get-function (gnus-server-to-method server)
+                          'request-compact)
+      (error
+       (error "This back end doesn't support compaction")))
+    (gnus-message 5 "\
+Requesting compaction of %s... (this may take a long time)"
+                 server)
+    (unless (gnus-open-server server)
+      (error "Couldn't open server"))
+    (if (gnus-request-compact server)
+       (gnus-message 5 "Requesting compaction of %s...done" server)
+      (gnus-message 5 "Couldn't compact %s" server))))
+
 (provide 'gnus-srvr)
 
 ;;; gnus-srvr.el ends here

diff --git a/lisp/nnml.el b/lisp/nnml.el
index dcdb5ea..d5e18fa 100644 (file)
--- a/lisp/nnml.el
+++ b/lisp/nnml.el
@@ -3,8 +3,9 @@
 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
 ;;   2004, 2005 Free Software Foundation, Inc.
 
-;; Author: Simon Josefsson <simon@josefsson.org> (adding MARKS)
-;;      Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; Authors: Didier Verna <didier@xemacs.org> (adding compaction)
+;;     Simon Josefsson <simon@josefsson.org> (adding MARKS)
+;;     Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;;     Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
 ;; Keywords: news, mail
 
@@ -377,7 +378,7 @@ non-nil.")
   (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")))
@@ -1016,6 +1017,145 @@ 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
+;;;
+
+(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:
+             (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 "\\("
+                                      (int-to-string old-number)
+                                      "\\)\\(\\(\\.gz\\)?\\)$")
+                      (concat (int-to-string new-number) "\\2"))))
+               (with-current-buffer nntp-server-buffer
+                 (nnmail-find-file oldfile)
+                 (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)
+                   (looking-at (int-to-string old-number))
+                   (replace-match (int-to-string new-number) nil t)))))
+           (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)
 
 ;;; nnml.el ends here

diff --git a/lisp/sieve.el b/lisp/sieve.el
index 5b355ad..165d40e 100644 (file)
--- a/lisp/sieve.el
+++ b/lisp/sieve.el
@@ -245,7 +245,7 @@ Used to bracket operations which move point in the sieve-buffer."
   (if (eq last-command 'sieve-help)
       ;; would need minor-mode for log-edit-mode
       (describe-function 'sieve-mode)
-    (message (substitute-command-keys
+    (message "%s" (substitute-command-keys
              "`\\[sieve-edit-script]':edit `\\[sieve-activate]':activate `\\[sieve-deactivate]':deactivate `\\[sieve-remove]':remove"))))
 
 (defun sieve-bury-buffer (buf &optional mainbuf)