From: yamaoka Date: Mon, 19 Sep 2005 13:57:16 +0000 (+0000) Subject: Synch to No Gnus 200509191333. X-Git-Tag: t-gnus-6_17_4-quimby-~360 X-Git-Url: http://git.chise.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=f6fe04a6c75532e7e5f1cb2ca3980c9478d41ff3;p=elisp%2Fgnus.git- Synch to No Gnus 200509191333. --- diff --git a/lisp/ChangeLog b/lisp/ChangeLog index d319984..552b5ac 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,22 @@ +2005-09-19 Didier Verna + + 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 + + * sieve.el (sieve-help): Fix `message' call: first arg should be a + format spec. + 2005-09-16 Katsumi Yamaoka * 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 --- 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 --- 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 --- 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 --- 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 (adding MARKS) -;; Lars Magne Ingebrigtsen +;; Authors: Didier Verna (adding compaction) +;; Simon Josefsson (adding MARKS) +;; Lars Magne Ingebrigtsen ;; Masanobu UMEDA ;; 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 --- 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)