diff options
| -rw-r--r-- | lisp/gnus/ChangeLog | 287 | ||||
| -rw-r--r-- | lisp/gnus/gnus-agent.el | 1100 | ||||
| -rw-r--r-- | lisp/gnus/gnus-cache.el | 40 | ||||
| -rw-r--r-- | lisp/gnus/gnus-draft.el | 74 | ||||
| -rw-r--r-- | lisp/gnus/gnus-group.el | 27 | ||||
| -rw-r--r-- | lisp/gnus/gnus-int.el | 58 | ||||
| -rw-r--r-- | lisp/gnus/gnus-range.el | 67 | ||||
| -rw-r--r-- | lisp/gnus/gnus-start.el | 253 | ||||
| -rw-r--r-- | lisp/gnus/gnus-sum.el | 118 | ||||
| -rw-r--r-- | lisp/gnus/gnus-util.el | 30 | ||||
| -rw-r--r-- | lisp/gnus/mm-view.el | 15 | ||||
| -rw-r--r-- | lisp/gnus/nnagent.el | 13 |
12 files changed, 1431 insertions, 651 deletions
diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index 9a43b077ea7..7e56de4c9f7 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,3 +1,290 @@ +2004-10-19 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-sum.el (gnus-update-summary-mark-positions): Search for + dummy marks in the right way. + +2004-10-18 Kevin Greiner <kgreiner@compsol.cc> + + * nnagent.el (nnagent-request-type): Bind gnus-agent to nil to + avoid infinite recursion via gnus-get-function. + +2004-10-18 Kevin Greiner <kgreiner@compsol.cc> + + * gnus-agent.el (gnus-agent-synchronize-group-flags): When + necessary, pass full group name to gnus-request-set-marks. + (gnus-agent-synchronize-group-flags): Added support for sync'ing + tick marks. + (gnus-agent-synchronize-flags-server): Be silent when writing file. + +2004-10-18 Kevin Greiner <kgreiner@compsol.cc> + + * gnus-agent.el (gnus-agent-synchronize-group-flags): Replaced + gnus-request-update-info with explicit code to sync the in-memory + info read flags with the marks being sync'd to the backend. + +2004-10-18 Kevin Greiner <kgreiner@compsol.cc> + + * gnus-agent.el (gnus-agent-possibly-synchronize-flags): Ignore + servers that are offline. Avoids having gnus-agent-toggle-plugged + first ask if you want to open a server and then, even when you + responded with no, asking if you want to synchronize the server's + flags. + (gnus-agent-synchronize-flags-server): Rewrote read loop to handle + multi-line expressions. + (gnus-agent-synchronize-group-flags): New internal function. + Updates marks in memory (in the info structure) AND in the + backend. + (gnus-agent-check-overview-buffer): Fixed range of + deletion to remove entire duplicate line. Fixes merged article + number bug. + + * gnus-util.el (gnus-remassoc): Fixed typo in documentation. + + * nnagent.el (nnagent-request-set-mark): Use + gnus-agent-synchronize-group-flags, not backend's request-set-mark + method, to ensure that synchronization updates marks in the + backend and in the info (in memory) structure. + +2004-10-18 Kevin Greiner <kgreiner@compsol.cc> + + * gnus-agent.el (gnus-agent-synchronize-flags-server): Do nothing + unless plugged. Disable the agent so that an open failure causes + an error. + +2004-10-18 Kevin Greiner <kevin.greiner@compsol.cc> for Reiner Steib <Reiner.Steib@gmx.de> + * gnus-agent.el (gnus-agent-fetched-hook): Add :version. + (gnus-agent-go-online): Change :version. + (gnus-agent-expire-unagentized-dirs) + (gnus-agent-auto-agentize-methods): Add :version. + +2004-10-18 Kevin Greiner <kgreiner@compsol.cc> + + * legacy-gnus-agent.el (gnus-agent-convert-to-compressed-agentview-prompt): + New function. Used internally to only display 'gnus converting + files' message when actually necessary. + + * gnus-sum.el (): Removed (require 'gnus-agent) as required + methods now autoloaded. + + * gnus-int.el (gnus-request-move-article): Use + gnus-agent-unfetch-articles in place of gnus-agent-expire to + improve performance. + +2004-10-18 Kevin Greiner <kgreiner@compsol.cc> + + * gnus-agent.el (gnus-agent-cat-groups): rewrote avoiding defsetf + to avoid run-time CL dependencies. + (gnus-agent-unfetch-articles): New function. + (gnus-agent-fetch-headers): Use gnus-agent-braid-nov to validate + article numbers even when local .overview file is missing. + (gnus-agent-read-article-number): New function. Only accepts + 27-bit article numbers. + (gnus-agent-copy-nov-line, gnus-agent-uncached-articles): Use + gnus-agent-read-article-number. + (gnus-agent-braid-nov): Rewrote to validate article numbers coming + from backend while recognizing that article numbers in .overview + must be valid. + + * gnus-start.el (gnus-convert-old-newsrc): Changed message text as + some users confused by references to .newsrc when they only have a + .newsrc.eld file. + (gnus-convert-mark-converter-prompt, + gnus-convert-converter-needs-prompt): Fixed use of property list. + +2004-10-18 Kevin Greiner <kevin.greiner@compsol.cc> for Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-agent.el (gnus-agent-restore-gcc): Use ^ and regexp-quote. + +2004-10-18 Kevin Greiner <kevin.greiner@compsol.cc> for Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-start.el (gnus-get-unread-articles-in-group): Don't do + stuff for non-living groups. + +2004-10-18 Kevin Greiner <kevin.greiner@compsol.cc> for Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-agent.el (gnus-agent-synchronize-flags): Default to nil. + (gnus-agent-regenerate-group): Using nil messages aren't valid. + +2004-10-18 Kevin Greiner <kevin.greiner@compsol.cc> for Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-agent.el (gnus-agent-read-agentview): Inline + gnus-uncompress-range. + +2004-10-18 Kevin Greiner <kgreiner@xpediantsolutions.com> + + * legacy-gnus-agent.el + (gnus-agent-convert-to-compressed-agentview): Fixed typos with + help from Florian Weimer <fw@deneb.enyo.de> + + * gnus-agent.el (gnus-agentize): + gnus-agent-send-mail-real-function no longer set to current value + of message-send-mail-function but rather a lambda that calls + message-send-mail-function. The change makes the agent real-time + responsive to user changes to message-send-mail-function. + +2004-10-18 Kevin Greiner <kevin.greiner@compsol.cc> for Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-start.el (gnus-get-unread-articles): Fix last commit. + +2004-10-18 Kevin Greiner <kgreiner@xpediantsolutions.com> + + * gnus-cache.el (gnus-cache-rename-group): New function. + (gnus-cache-delete-group): New function. + + * gnus-agent.el (gnus-agent-rename-group): New function. + (gnus-agent-delete-group): New function. + (gnus-agent-save-group-info): Use gnus-command-method when + `method' parameter is nil. Don't write nil entries into the + active file. + (gnus-agent-get-group-info): New function. + (gnus-agent-get-local): Added optional parameters to avoid calling + gnus-group-real-name and gnus-find-method-for-group. + (gnus-agent-set-local): Delete stored entry if either min, or max, + are nil. + (gnus-agent-fetch-session): Reworded error/quit messages. On + quit, use gnus-agent-regenerate-group to record existance of any + articles fetched to disk before the quit occurred. + + * gnus-int.el (gnus-request-delete-group): Use + gnus-cache-delete-group and gnus-agent-delete-group to keep the + local disk in sync with the server. + (gnus-request-rename-group): Use + gnus-cache-rename-group and gnus-agent-rename-group to keep the + local disk in sync with the server. + + * gnus-start.el (gnus-get-unread-articles): Cosmetic + simplification to logic. + + * gnus-group.el (): (gnus-group-delete-group): No longer update + gnus-cache-active-altered as gnus-request-delete-group now keeps + the cache in sync. + (gnus-group-list-active): Let the agent store a server's active + list if currently plugged. + + * gnus-util.el (gnus-rename-file): New function. + +2004-10-18 Kevin Greiner <kevin.greiner@compsol.cc> for Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-agent.el (gnus-agent-regenerate-group): Activate the group + when the group's active is not available. + +2004-10-18 Kevin Greiner <kevin.greiner@compsol.cc> for Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-agent.el (gnus-agent-read-agentview): Add a missing arg to + error. + +2004-10-18 Kevin Greiner <kevin.greiner@compsol.cc> + + * gnus-start.el (gnus-convert-old-newsrc): Only write the + conversion message to newsrc-dribble when an actual conversion is + performed. + +2004-10-18 Kevin Greiner <kevin.greiner@compsol.cc> + + * gnus-agent.el (gnus-agent-read-local): Bind + nnheader-file-coding-system to gnus-agent-file-coding-system to + avoid the implicit assumption that they will always be equal. + (gnus-agent-save-local): Bind buffer-file-coding-system, not + coding-system-for-write, as the with-temp-file macro first prints + to a buffer then saves the buffer. + +2004-10-18 Kevin Greiner <kgreiner@xpediantsolutions.com> + + * legacy-gnus-agent.el (): New. Provides converters that are only + loaded when gnus-convert-old-newsrc needs to call them. + + * gnus-agent.el (gnus-agent-read-agentview): Removed support for + old file versions. + (gnus-group-prepare-hook): Removed function that converted list + form of gnus-agent-expire-days to group properties. + + * gnus-start.el (gnus-convert-old-newsrc): Registered new + converters to handle old agent file formats. Added logic for a + "backup before upgrading warning". + (gnus-convert-mark-converter-prompt): Developers can mark + functions as needing (default), or not needing, + gnus-convert-old-newsrc's "backup before upgrading warning". + (gnus-convert-converter-needs-prompt): Tests whether the user + should be protected from potentially irreversable changes by the + function. + +2004-10-18 Kevin Greiner <kgreiner@xpediantsolutions.com> + + * gnus-int.el (gnus-request-accept-article): Inform the agent that + articles are being added to a group. + (gnus-request-replace-article): Inform the agent that articles + need to be uncached as the cached contents are no longer valid. + + * gnus-agent.el (gnus-agent-file-header-cache): Removed. + (gnus-agent-possibly-alter-active): Avoid null in numeric + comparison. + (gnus-agent-set-local): Refuse to save null in local object table. + (gnus-agent-regenerate-group): The REREAD parameter can now be a + list of articles that will be marked as unread. + +2004-10-18 Kevin Greiner <kevin.greiner@compsol.cc> + + * gnus-range.el (gnus-sorted-range-intersection): Now accepts + single-interval range of the form (min . max). Previously the + range had to look like ((min . max)). Likewise, return + (min . max) rather than ((min . max)). + (gnus-range-map): Use gnus-range-normalize to accept + single-interval range. + + * gnus-sum.el (gnus-summary-highlight-line): Articles stored in + the cache, but not the agent, now appear with their usual face. + +2004-10-18 Kevin Greiner <kevin.greiner@compsol.cc> + + * gnus-sum.el (gnus-adjust-marks): Now correctly handles a list of + marks consisting of a single range {for example, (3 . 5)} rather + than a list of a single range { ((3 . 5)) }. + +2004-10-18 Kevin Greiner <kevin.greiner@compsol.cc> + + * gnus-sum.el (gnus-adjust-marks): Avoid splicing null INTO the + uncompressed list. + +2004-10-18 Kevin Greiner <kevin.greiner@compsol.cc> + + * gnus-draft.el (gnus-group-send-queue): Pass the group name + "nndraft:queue" along to gnus-draft-send. Use + gnus-agent-prompt-send-queue. + (gnus-draft-send): Rebind gnus-agent-queue-mail to nil when group + is "nndraft:queue". Suggested by Gaute Strokkenes + <gs234@srcf.ucam.org> + + * gnus-group.el (gnus-group-catchup): Use new + gnus-sequence-of-unread-articles, not + gnus-list-of-unread-articles, to avoid exhausting memory with huge + numbers of articles. Use gnus-range-map to avoid having to + uncompress the unread list. + (gnus-group-archive-directory, + gnus-group-recent-archive-directory): Fixed invalid ange-ftp + reference. + + * gnus-range.el (gnus-range-map): Iterate over list or sequence. + (gnus-sorted-range-intersection): Intersection of two ranges + without requiring that they first be uncompressed. + + * gnus-start.el (gnus-activate-group): Unless blocked by the + caller, possibly expand the active range to include both cached + and agentized articles. + (gnus-convert-old-newsrc): Rewrote in anticipation of having + multiple version-dependent converters. + (gnus-groups-to-gnus-format): Replaced gnus-agent-save-groups with + gnus-agent-save-active. + (gnus-save-newsrc-file): Save dirty agent range limits. + + * gnus-sum.el (gnus-select-newgroup): Replaced inline code with + gnus-agent-possibly-alter-active. + (gnus-adjust-marked-articles): Faster handling of simple lists + +2004-10-18 David Edmondson <dme@dme.org> + + * mm-view.el (mm-w3m-cid-retrieve-1): Don't use recursive call + excessively. + 2004-10-18 Reiner Steib <Reiner.Steib@gmx.de> * mml.el (mml-preview): Use `pop-to-buffer'. diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index 4596c783d32..c62460946ab 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -114,7 +114,7 @@ If nil, only read articles will be expired." :group 'gnus-agent :type 'function) -(defcustom gnus-agent-synchronize-flags 'ask +(defcustom gnus-agent-synchronize-flags nil "Indicate if flags are synchronized when you plug in. If this is `ask' the hook will query the user." :version "21.1" @@ -362,9 +362,23 @@ manipulated as follows: (gnus-agent-cat-defaccessor gnus-agent-cat-enable-undownloaded-faces agent-enable-undownloaded-faces) + +;; This form is equivalent to defsetf except that it calls make-symbol +;; whereas defsetf calls gensym (Using gensym creates a run-time +;; dependency on the CL library). + (eval-and-compile - (defsetf gnus-agent-cat-groups (category) (groups) - (list 'gnus-agent-set-cat-groups category groups))) + (define-setf-method gnus-agent-cat-groups (category) + (let* ((--category--temp-- (make-symbol "--category--")) + (--groups--temp-- (make-symbol "--groups--"))) + (list (list --category--temp--) + (list category) + (list --groups--temp--) + (let* ((category --category--temp--) + (groups --groups--temp--)) + (list (quote gnus-agent-set-cat-groups) category groups)) + (list (quote gnus-agent-cat-groups) --category--temp--)))) + ) (defun gnus-agent-set-cat-groups (category groups) (unless (eq groups 'ignore) @@ -624,7 +638,7 @@ minor mode in all Gnus buffers." (unless gnus-agent-send-mail-function (setq gnus-agent-send-mail-function (or message-send-mail-real-function - message-send-mail-function) + (function (lambda () (funcall message-send-mail-function)))) message-send-mail-real-function 'gnus-agent-send-mail)) ;; If the servers file doesn't exist, auto-agentize some servers and @@ -790,25 +804,39 @@ be a select method." (interactive) (save-excursion (dolist (gnus-command-method (gnus-agent-covered-methods)) - (when (file-exists-p (gnus-agent-lib-file "flags")) + (when (and (file-exists-p (gnus-agent-lib-file "flags")) + (not (eq (gnus-server-status gnus-command-method) 'offline))) (gnus-agent-possibly-synchronize-flags-server gnus-command-method))))) (defun gnus-agent-synchronize-flags-server (method) "Synchronize flags set when unplugged for server." - (let ((gnus-command-method method)) + (let ((gnus-command-method method) + (gnus-agent nil)) (when (file-exists-p (gnus-agent-lib-file "flags")) (set-buffer (get-buffer-create " *Gnus Agent flag synchronize*")) (erase-buffer) (nnheader-insert-file-contents (gnus-agent-lib-file "flags")) - (if (null (gnus-check-server gnus-command-method)) - (gnus-message 1 "Couldn't open server %s" (nth 1 gnus-command-method)) - (while (not (eobp)) - (if (null (eval (read (current-buffer)))) - (gnus-delete-line) - (write-file (gnus-agent-lib-file "flags")) - (error "Couldn't set flags from file %s" - (gnus-agent-lib-file "flags")))) - (delete-file (gnus-agent-lib-file "flags"))) + (cond ((null gnus-plugged) + (gnus-message + 1 "You must be plugged to synchronize flags with server %s" + (nth 1 gnus-command-method))) + ((null (gnus-check-server gnus-command-method)) + (gnus-message + 1 "Couldn't open server %s" (nth 1 gnus-command-method))) + (t + (condition-case err + (while t + (let ((bgn (point))) + (eval (read (current-buffer))) + (delete-region bgn (point)))) + (end-of-file + (delete-file (gnus-agent-lib-file "flags"))) + (error + (let ((file (gnus-agent-lib-file "flags"))) + (write-region (point-min) (point-max) + (gnus-agent-lib-file "flags") nil 'silent) + (error "Couldn't set flags from file %s due to %s" + file (error-message-string err))))))) (kill-buffer nil)))) (defun gnus-agent-possibly-synchronize-flags-server (method) @@ -820,6 +848,56 @@ be a select method." (cadr method))))) (gnus-agent-synchronize-flags-server method))) +;;;###autoload +(defun gnus-agent-rename-group (old-group new-group) + "Rename fully-qualified OLD-GROUP as NEW-GROUP. Always updates the agent, even when +disabled, as the old agent files would corrupt gnus when the agent was +next enabled. Depends upon the caller to determine whether group renaming is supported." + (let* ((old-command-method (gnus-find-method-for-group old-group)) + (old-path (directory-file-name + (let (gnus-command-method old-command-method) + (gnus-agent-group-pathname old-group)))) + (new-command-method (gnus-find-method-for-group new-group)) + (new-path (directory-file-name + (let (gnus-command-method new-command-method) + (gnus-agent-group-pathname new-group))))) + (gnus-rename-file old-path new-path t) + + (let* ((old-real-group (gnus-group-real-name old-group)) + (new-real-group (gnus-group-real-name new-group)) + (old-active (gnus-agent-get-group-info old-command-method old-real-group))) + (gnus-agent-save-group-info old-command-method old-real-group nil) + (gnus-agent-save-group-info new-command-method new-real-group old-active) + + (let ((old-local (gnus-agent-get-local old-group + old-real-group old-command-method))) + (gnus-agent-set-local old-group + nil nil + old-real-group old-command-method) + (gnus-agent-set-local new-group + (car old-local) (cdr old-local) + new-real-group new-command-method))))) + +;;;###autoload +(defun gnus-agent-delete-group (group) + "Delete fully-qualified GROUP. Always updates the agent, even when +disabled, as the old agent files would corrupt gnus when the agent was +next enabled. Depends upon the caller to determine whether group deletion is supported." + (let* ((command-method (gnus-find-method-for-group group)) + (path (directory-file-name + (let (gnus-command-method command-method) + (gnus-agent-group-pathname group))))) + (gnus-delete-file path) + + (let* ((real-group (gnus-group-real-name group))) + (gnus-agent-save-group-info command-method real-group nil) + + (let ((local (gnus-agent-get-local group + real-group command-method))) + (gnus-agent-set-local group + nil nil + real-group command-method))))) + ;;; ;;; Server mode commands ;;; @@ -969,6 +1047,7 @@ article's mark is toggled." gnus-downloadable-mark) 'unread)))) +;;;###autoload (defun gnus-agent-get-undownloaded-list () "Construct list of articles that have not been downloaded." (let ((gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name))) @@ -1113,6 +1192,49 @@ This can be added to `gnus-select-article-hook' or ;;; Internal functions ;;; +(defun gnus-agent-synchronize-group-flags (group actions server) +"Update a plugged group by performing the indicated actions." + (let* ((gnus-command-method (gnus-server-to-method server)) + (info + ;; This initializer is required as gnus-request-set-mark + ;; calls gnus-group-real-name to strip off the host name + ;; before calling the backend. Now that the backend is + ;; trying to call gnus-request-set-mark, I have to + ;; reconstruct the original group name. + (or (gnus-get-info group) + (gnus-get-info + (setq group (gnus-group-full-name + group gnus-command-method)))))) + (gnus-request-set-mark group actions) + + (when info + (dolist (action actions) + (let ((range (nth 0 action)) + (what (nth 1 action)) + (marks (nth 2 action))) + (dolist (mark marks) + (cond ((eq mark 'read) + (gnus-info-set-read + info + (funcall (if (eq what 'add) + 'gnus-range-add + 'gnus-remove-from-range) + (gnus-info-read info) + range)) + (gnus-get-unread-articles-in-group + info + (gnus-active (gnus-info-group info)))) + ((memq mark '(tick)) + (let ((info-marks (assoc mark (gnus-info-marks info)))) + (unless info-marks + (gnus-info-set-marks info (cons (setq info-marks (list mark)) (gnus-info-marks info)))) + (setcdr info-marks (funcall (if (eq what 'add) + 'gnus-range-add + 'gnus-remove-from-range) + (cdr info-marks) + range))))))))) + nil)) + (defun gnus-agent-save-active (method) (when (gnus-agent-method-p method) (let* ((gnus-command-method method) @@ -1131,6 +1253,7 @@ This can be added to `gnus-select-article-hook' or ;; will add it while reading the file. (gnus-write-active-file file new nil))) +;;;###autoload (defun gnus-agent-possibly-alter-active (group active &optional info) "Possibly expand a group's active range to include articles downloaded into the agent." @@ -1183,7 +1306,7 @@ downloaded into the agent." (defun gnus-agent-save-group-info (method group active) "Update a single group's active range in the agent's copy of the server's active file." (when (gnus-agent-method-p method) - (let* ((gnus-command-method method) + (let* ((gnus-command-method (or method gnus-command-method)) (coding-system-for-write nnheader-file-coding-system) (file-name-coding-system nnmail-pathname-coding-system) (file (gnus-agent-lib-file "active")) @@ -1199,15 +1322,39 @@ downloaded into the agent." (when (re-search-forward (concat "^" (regexp-quote group) " ") nil t) (save-excursion - (setq oactive-max (read (current-buffer)) ;; max + (setq oactive-max (read (current-buffer)) ;; max oactive-min (read (current-buffer)))) ;; min (gnus-delete-line))) - (insert (format "%S %d %d y\n" (intern group) - (max (or oactive-max (cdr active)) (cdr active)) - (min (or oactive-min (car active)) (car active)))) - (goto-char (point-max)) - (while (search-backward "\\." nil t) - (delete-char 1)))))) + (when active + (insert (format "%S %d %d y\n" (intern group) + (max (or oactive-max (cdr active)) (cdr active)) + (min (or oactive-min (car active)) (car active)))) + (goto-char (point-max)) + (while (search-backward "\\." nil t) + (delete-char 1))))))) + +(defun gnus-agent-get-group-info (method group) + "Get a single group's active range in the agent's copy of the server's active file." + (when (gnus-agent-method-p method) + (let* ((gnus-command-method (or method gnus-command-method)) + (coding-system-for-write nnheader-file-coding-system) + (file-name-coding-system nnmail-pathname-coding-system) + (file (gnus-agent-lib-file "active")) + oactive-min oactive-max) + (gnus-make-directory (file-name-directory file)) + (with-temp-buffer + ;; Emacs got problem to match non-ASCII group in multibyte buffer. + (mm-disable-multibyte) + (when (file-exists-p file) + (nnheader-insert-file-contents file) + + (goto-char (point-min)) + (when (re-search-forward + (concat "^" (regexp-quote group) " ") nil t) + (save-excursion + (setq oactive-max (read (current-buffer)) ;; max + oactive-min (read (current-buffer))) ;; min + (cons oactive-min oactive-max)))))))) (defun gnus-agent-group-path (group) "Translate GROUP into a file name." @@ -1413,6 +1560,31 @@ downloaded into the agent." (gnus-message 7 "")) (cdr fetched-articles)))))) +(defun gnus-agent-unfetch-articles (group articles) + "Delete ARTICLES that were fetched from GROUP into the agent." + (when articles + (gnus-agent-load-alist group) + (let* ((alist (cons nil gnus-agent-article-alist)) + (articles (sort articles #'<)) + (next-possibility alist) + (delete-this (pop articles))) + (while (and (cdr next-possibility) delete-this) + (let ((have-this (caar (cdr next-possibility)))) + (cond ((< delete-this have-this) + (setq delete-this (pop articles))) + ((= delete-this have-this) + (let ((timestamp (cdar (cdr next-possibility)))) + (when timestamp + (let* ((file-name (concat (gnus-agent-group-pathname group) + (number-to-string have-this)))) + (delete-file file-name)))) + + (setcdr next-possibility (cddr next-possibility))) + (t + (setq next-possibility (cdr next-possibility)))))) + (setq gnus-agent-article-alist (cdr alist)) + (gnus-agent-save-alist group)))) + (defun gnus-agent-crosspost (crosses article &optional date) (setq date (or date t)) @@ -1487,7 +1659,7 @@ and that there are no duplicates." (setq backed-up (gnus-agent-backup-overview-buffer))) (gnus-message 1 "Duplicate overview line for %d" cur) - (delete-region (point) (progn (forward-line 1) (point)))) + (delete-region p (progn (forward-line 1) (point)))) ((< cur prev-num) (or backed-up (setq backed-up (gnus-agent-backup-overview-buffer))) @@ -1519,6 +1691,7 @@ and that there are no duplicates." (insert "\n")) (setq gnus-agent-group-alist (cdr gnus-agent-group-alist))))) +;;;###autoload (defun gnus-agent-find-parameter (group symbol) "Search for GROUPs SYMBOL in the group's parameters, the group's topic parameters, the group's category, or the customizable @@ -1623,8 +1796,10 @@ article numbers will be returned." ;; of FILE. (copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max)) - (when (file-exists-p file) - (gnus-agent-braid-nov group articles file)) + ;; NOTE: Call g-a-brand-nov even when the file does not + ;; exist. As a minimum, it will validate the article + ;; numbers already in the buffer. + (gnus-agent-braid-nov group articles file) (let ((coding-system-for-write gnus-agent-file-coding-system)) (gnus-agent-check-overview-buffer) @@ -1636,11 +1811,32 @@ article numbers will be returned." (nnheader-insert-file-contents file))))) articles)) +(defsubst gnus-agent-read-article-number () + "Reads the article number at point. Returns nil when a valid article number can not be read." + + ;; It is unfortunite but the read function quietly overflows + ;; integer. As a result, I have to use string operations to test + ;; for overflow BEFORE calling read. + (when (looking-at "[0-9]+\t") + (let ((len (- (match-end 0) (match-beginning 0)))) + (cond ((< len 9) + (read (current-buffer))) + ((= len 9) + ;; Many 9 digit base-10 numbers can be represented in a 27-bit int + ;; Back convert from int to string to ensure that this is one of them. + (let* ((str1 (buffer-substring (match-beginning 0) (1- (match-end 0)))) + (num (read (current-buffer))) + (str2 (int-to-string num))) + (when (equal str1 str2) + num))))))) + (defsubst gnus-agent-copy-nov-line (article) + "Copy the indicated ARTICLE from the overview buffer to the nntp server buffer." (let (art b e) (set-buffer gnus-agent-overview-buffer) (while (and (not (eobp)) - (< (setq art (read (current-buffer))) article)) + (or (not (setq art (gnus-agent-read-article-number))) + (< art article))) (forward-line 1)) (beginning-of-line) (if (or (eobp) @@ -1653,64 +1849,77 @@ article numbers will be returned." (defun gnus-agent-braid-nov (group articles file) "Merge agent overview data with given file. -Takes headers for ARTICLES from `gnus-agent-overview-buffer' and the given -FILE and places the combined headers into `nntp-server-buffer'." +Takes unvalidated headers for ARTICLES from +`gnus-agent-overview-buffer' and validated headers from the given +FILE and places the combined valid headers into +`nntp-server-buffer'. This function can be used, when file +doesn't exist, to valid the overview buffer." (let (start last) (set-buffer gnus-agent-overview-buffer) (goto-char (point-min)) (set-buffer nntp-server-buffer) (erase-buffer) - (nnheader-insert-file-contents file) + (when (file-exists-p file) + (nnheader-insert-file-contents file)) (goto-char (point-max)) (forward-line -1) - (unless (looking-at "[0-9]+\t") - ;; Remove corrupted lines - (gnus-message - 1 "Overview %s is corrupted. Removing corrupted lines..." file) - (goto-char (point-min)) - (while (not (eobp)) - (if (looking-at "[0-9]+\t") - (forward-line 1) - (delete-region (point) (progn (forward-line 1) (point))))) - (forward-line -1)) + (unless (or (= (point-min) (point-max)) (< (setq last (read (current-buffer))) (car articles))) - ;; We do it the hard way. + ;; Old and new overlap -- We do it the hard way. (when (nnheader-find-nov-line (car articles)) ;; Replacing existing NOV entry (delete-region (point) (progn (forward-line 1) (point)))) (gnus-agent-copy-nov-line (pop articles)) (ignore-errors - (while articles - (while (let ((art (read (current-buffer)))) - (cond ((< art (car articles)) - (forward-line 1) - t) - ((= art (car articles)) - (beginning-of-line) - (delete-region - (point) (progn (forward-line 1) (point))) - nil) - (t - (beginning-of-line) - nil)))) - - (gnus-agent-copy-nov-line (pop articles))))) - - ;; Copy the rest lines - (set-buffer nntp-server-buffer) + (while articles + (while (let ((art (read (current-buffer)))) + (cond ((< art (car articles)) + (forward-line 1) + t) + ((= art (car articles)) + (beginning-of-line) + (delete-region + (point) (progn (forward-line 1) (point))) + nil) + (t + (beginning-of-line) + nil)))) + + (gnus-agent-copy-nov-line (pop articles))))) + (goto-char (point-max)) + + ;; Append the remaining lines (when articles (when last (set-buffer gnus-agent-overview-buffer) - (ignore-errors - (while (<= (read (current-buffer)) last) - (forward-line 1))) - (beginning-of-line) (setq start (point)) (set-buffer nntp-server-buffer)) - (insert-buffer-substring gnus-agent-overview-buffer start)))) + + (let ((p (point))) + (insert-buffer-substring gnus-agent-overview-buffer start) + (goto-char p)) + + (setq last (or last -134217728)) + (let (sort art) + (while (not (eobp)) + (setq art (gnus-agent-read-article-number)) + (cond ((not art) + ;; Bad art num - delete this line + (beginning-of-line) + (delete-region (point) (progn (forward-line 1) (point)))) + ((< art last) + ;; Art num out of order - enable sort + (setq sort t) + (forward-line 1)) + (t + ;; Good art num + (setq last art) + (forward-line 1)))) + (when sort + (sort-numeric-fields 1 (point-min) (point-max))))))) ;; Keeps the compiler from warning about the free variable in ;; gnus-agent-read-agentview. @@ -1735,7 +1944,8 @@ FILE and places the combined headers into `nntp-server-buffer'." (defun gnus-agent-read-agentview (file) "Load FILE and do a `read' there." (with-temp-buffer - (ignore-errors + (condition-case nil + (progn (nnheader-insert-file-contents file) (goto-char (point-min)) (let ((alist (read (current-buffer))) @@ -1744,6 +1954,8 @@ FILE and places the combined headers into `nntp-server-buffer'." changed-version) (cond + ((< version 2) + (error "gnus-agent-read-agentview no longer supports version %d. Stop gnus, manually evaluate gnus-agent-convert-to-compressed-agentview, then restart gnus." version)) ((= version 0) (let ((inhibit-quit t) entry) @@ -1767,8 +1979,9 @@ FILE and places the combined headers into `nntp-server-buffer'." (mapcar (lambda (comp-list) (let ((state (car comp-list)) - (sequence (gnus-uncompress-sequence - (cdr comp-list)))) + (sequence (inline + (gnus-uncompress-range + (cdr comp-list))))) (mapcar (lambda (article-id) (setq uncomp (cons (cons article-id state) uncomp))) sequence))) @@ -1777,7 +1990,8 @@ FILE and places the combined headers into `nntp-server-buffer'." (when changed-version (let ((gnus-agent-article-alist alist)) (gnus-agent-save-alist gnus-agent-read-agentview))) - alist)))) + alist)) + (file-error nil)))) (defun gnus-agent-save-alist (group &optional articles state) "Save the article-state alist for GROUP." @@ -1860,7 +2074,8 @@ modified) original contents, they are first saved to their own file." (line 1)) (with-temp-buffer (condition-case nil - (nnheader-insert-file-contents file) + (let ((nnheader-file-coding-system gnus-agent-file-coding-system)) + (nnheader-insert-file-contents file)) (file-error)) (goto-char (point-min)) @@ -1903,31 +2118,31 @@ modified) original contents, they are first saved to their own file." ;; NOTE: gnus-command-method is used within gnus-agent-lib-file. (dest (gnus-agent-lib-file "local"))) (gnus-make-directory (gnus-agent-lib-file "")) - (with-temp-file dest - (let ((gnus-command-method (symbol-value (intern "+method" my-obarray))) - (file-name-coding-system nnmail-pathname-coding-system) - (coding-system-for-write - gnus-agent-file-coding-system) - print-level print-length item article - (standard-output (current-buffer))) - (mapatoms (lambda (symbol) - (cond ((not (boundp symbol)) - nil) - ((member (symbol-name symbol) '("+dirty" "+method")) - nil) - (t - (prin1 symbol) - (let ((range (symbol-value symbol))) - (princ " ") - (princ (car range)) - (princ " ") - (princ (cdr range)) - (princ "\n"))))) - my-obarray))))))) - -(defun gnus-agent-get-local (group) - (let* ((gmane (gnus-group-real-name group)) - (gnus-command-method (gnus-find-method-for-group group)) + + (let ((buffer-file-coding-system gnus-agent-file-coding-system)) + (with-temp-file dest + (let ((gnus-command-method (symbol-value (intern "+method" my-obarray))) + (file-name-coding-system nnmail-pathname-coding-system) + print-level print-length item article + (standard-output (current-buffer))) + (mapatoms (lambda (symbol) + (cond ((not (boundp symbol)) + nil) + ((member (symbol-name symbol) '("+dirty" "+method")) + nil) + (t + (prin1 symbol) + (let ((range (symbol-value symbol))) + (princ " ") + (princ (car range)) + (princ " ") + (princ (cdr range)) + (princ "\n"))))) + my-obarray)))))))) + +(defun gnus-agent-get-local (group &optional gmane method) + (let* ((gmane (or gmane (gnus-group-real-name group))) + (gnus-command-method (or method (gnus-find-method-for-group group))) (local (gnus-agent-load-local)) (symb (intern gmane local)) (minmax (and (boundp symb) (symbol-value symb)))) @@ -1962,7 +2177,9 @@ modified) original contents, they are first saved to their own file." nil) ((and min max) (set symb (cons min max)) - t)) + t) + (t + (unintern symb local))) (set (intern "+dirty" local) t)))) (defun gnus-agent-article-name (article group) @@ -2012,13 +2229,14 @@ modified) original contents, they are first saved to their own file." group gnus-command-method) (error (unless (funcall gnus-agent-confirmation-function - (format "Error %s. Continue? " + (format "Error %s while fetching session. Should gnus continue? " (error-message-string err))) (error "Cannot fetch articles into the Gnus agent"))) (quit + (gnus-agent-regenerate-group group) (unless (funcall gnus-agent-confirmation-function (format - "Quit fetching session %s. Continue? " + "%s while fetching session. Should gnus continue? " (error-message-string err))) (signal 'quit "Cannot fetch articles into the Gnus agent"))))))))) @@ -2736,328 +2954,334 @@ FORCE is equivalent to setting the expiration predicates to true." (let ((dir (gnus-agent-group-pathname group))) (when (boundp 'gnus-agent-expire-current-dirs) (set 'gnus-agent-expire-current-dirs - (cons dir - (symbol-value 'gnus-agent-expire-current-dirs)))) + (cons dir + (symbol-value 'gnus-agent-expire-current-dirs)))) (if (and (not force) - (eq 'DISABLE (gnus-agent-find-parameter group - 'agent-enable-expiration))) - (gnus-message 5 "Expiry skipping over %s" group) + (eq 'DISABLE (gnus-agent-find-parameter group + 'agent-enable-expiration))) + (gnus-message 5 "Expiry skipping over %s" group) (gnus-message 5 "Expiring articles in %s" group) (gnus-agent-load-alist group) - (let* ((stats (if (boundp 'gnus-agent-expire-stats) - ;; Use the list provided by my caller - (symbol-value 'gnus-agent-expire-stats) - ;; otherwise use my own temporary list - (list 0 0 0.0))) - (info (gnus-get-info group)) - (alist gnus-agent-article-alist) - (day (- (time-to-days (current-time)) - (gnus-agent-find-parameter group 'agent-days-until-old))) - (specials (if (and alist - (not force)) - ;; This could be a bit of a problem. I need to - ;; keep the last article to avoid refetching - ;; headers when using nntp in the backend. At - ;; the same time, if someone uses a backend - ;; that supports article moving then I may have - ;; to remove the last article to complete the - ;; move. Right now, I'm going to assume that - ;; FORCE overrides specials. - (list (caar (last alist))))) - (unreads ;; Articles that are excluded from the - ;; expiration process - (cond (gnus-agent-expire-all - ;; All articles are marked read by global decree - nil) - ((eq articles t) - ;; All articles are marked read by function - ;; parameter - nil) - ((not articles) - ;; Unread articles are marked protected from - ;; expiration Don't call - ;; gnus-list-of-unread-articles as it returns - ;; articles that have not been fetched into the - ;; agent. - (ignore-errors - (gnus-agent-unread-articles group))) - (t - ;; All articles EXCEPT those named by the caller - ;; are protected from expiration - (gnus-sorted-difference - (gnus-uncompress-range - (cons (caar alist) - (caar (last alist)))) - (sort articles '<))))) - (marked ;; More articles that are excluded from the - ;; expiration process - (cond (gnus-agent-expire-all - ;; All articles are unmarked by global decree - nil) - ((eq articles t) - ;; All articles are unmarked by function - ;; parameter - nil) - (articles - ;; All articles may as well be unmarked as the - ;; unreads list already names the articles we are - ;; going to keep - nil) - (t - ;; Ticked and/or dormant articles are excluded - ;; from expiration - (nconc - (gnus-uncompress-range - (cdr (assq 'tick (gnus-info-marks info)))) - (gnus-uncompress-range - (cdr (assq 'dormant - (gnus-info-marks info)))))))) - (nov-file (concat dir ".overview")) - (cnt 0) - (completed -1) - dlist - type) - - ;; The normal article alist contains elements that look like - ;; (article# . fetch_date) I need to combine other - ;; information with this list. For example, a flag indicating - ;; that a particular article MUST BE KEPT. To do this, I'm - ;; going to transform the elements to look like (article# - ;; fetch_date keep_flag NOV_entry_marker) Later, I'll reverse - ;; the process to generate the expired article alist. - - ;; Convert the alist elements to (article# fetch_date nil - ;; nil). - (setq dlist (mapcar (lambda (e) - (list (car e) (cdr e) nil nil)) alist)) - - ;; Convert the keep lists to elements that look like (article# - ;; nil keep_flag nil) then append it to the expanded dlist - ;; These statements are sorted by ascending precidence of the - ;; keep_flag. - (setq dlist (nconc dlist - (mapcar (lambda (e) - (list e nil 'unread nil)) - unreads))) - (setq dlist (nconc dlist - (mapcar (lambda (e) - (list e nil 'marked nil)) - marked))) - (setq dlist (nconc dlist - (mapcar (lambda (e) - (list e nil 'special nil)) - specials))) - - (set-buffer overview) - (erase-buffer) - (buffer-disable-undo) - (when (file-exists-p nov-file) - (gnus-message 7 "gnus-agent-expire: Loading overview...") - (nnheader-insert-file-contents nov-file) - (goto-char (point-min)) - - (let (p) - (while (< (setq p (point)) (point-max)) - (condition-case nil - ;; If I successfully read an integer (the plus zero - ;; ensures a numeric type), prepend a marker entry - ;; to the list - (push (list (+ 0 (read (current-buffer))) nil nil - (set-marker (make-marker) p)) - dlist) - (error - (gnus-message 1 "gnus-agent-expire: read error \ + (let* ((bytes-freed 0) + (files-deleted 0) + (nov-entries-deleted 0) + (info (gnus-get-info group)) + (alist gnus-agent-article-alist) + (day (- (time-to-days (current-time)) + (gnus-agent-find-parameter group 'agent-days-until-old))) + (specials (if (and alist + (not force)) + ;; This could be a bit of a problem. I need to + ;; keep the last article to avoid refetching + ;; headers when using nntp in the backend. At + ;; the same time, if someone uses a backend + ;; that supports article moving then I may have + ;; to remove the last article to complete the + ;; move. Right now, I'm going to assume that + ;; FORCE overrides specials. + (list (caar (last alist))))) + (unreads ;; Articles that are excluded from the + ;; expiration process + (cond (gnus-agent-expire-all + ;; All articles are marked read by global decree + nil) + ((eq articles t) + ;; All articles are marked read by function + ;; parameter + nil) + ((not articles) + ;; Unread articles are marked protected from + ;; expiration Don't call + ;; gnus-list-of-unread-articles as it returns + ;; articles that have not been fetched into the + ;; agent. + (ignore-errors + (gnus-agent-unread-articles group))) + (t + ;; All articles EXCEPT those named by the caller + ;; are protected from expiration + (gnus-sorted-difference + (gnus-uncompress-range + (cons (caar alist) + (caar (last alist)))) + (sort articles '<))))) + (marked ;; More articles that are excluded from the + ;; expiration process + (cond (gnus-agent-expire-all + ;; All articles are unmarked by global decree + nil) + ((eq articles t) + ;; All articles are unmarked by function + ;; parameter + nil) + (articles + ;; All articles may as well be unmarked as the + ;; unreads list already names the articles we are + ;; going to keep + nil) + (t + ;; Ticked and/or dormant articles are excluded + ;; from expiration + (nconc + (gnus-uncompress-range + (cdr (assq 'tick (gnus-info-marks info)))) + (gnus-uncompress-range + (cdr (assq 'dormant + (gnus-info-marks info)))))))) + (nov-file (concat dir ".overview")) + (cnt 0) + (completed -1) + dlist + type) + + ;; The normal article alist contains elements that look like + ;; (article# . fetch_date) I need to combine other + ;; information with this list. For example, a flag indicating + ;; that a particular article MUST BE KEPT. To do this, I'm + ;; going to transform the elements to look like (article# + ;; fetch_date keep_flag NOV_entry_marker) Later, I'll reverse + ;; the process to generate the expired article alist. + + ;; Convert the alist elements to (article# fetch_date nil + ;; nil). + (setq dlist (mapcar (lambda (e) + (list (car e) (cdr e) nil nil)) alist)) + + ;; Convert the keep lists to elements that look like (article# + ;; nil keep_flag nil) then append it to the expanded dlist + ;; These statements are sorted by ascending precidence of the + ;; keep_flag. + (setq dlist (nconc dlist + (mapcar (lambda (e) + (list e nil 'unread nil)) + unreads))) + (setq dlist (nconc dlist + (mapcar (lambda (e) + (list e nil 'marked nil)) + marked))) + (setq dlist (nconc dlist + (mapcar (lambda (e) + (list e nil 'special nil)) + specials))) + + (set-buffer overview) + (erase-buffer) + (buffer-disable-undo) + (when (file-exists-p nov-file) + (gnus-message 7 "gnus-agent-expire: Loading overview...") + (nnheader-insert-file-contents nov-file) + (goto-char (point-min)) + + (let (p) + (while (< (setq p (point)) (point-max)) + (condition-case nil + ;; If I successfully read an integer (the plus zero + ;; ensures a numeric type), prepend a marker entry + ;; to the list + (push (list (+ 0 (read (current-buffer))) nil nil + (set-marker (make-marker) p)) + dlist) + (error + (gnus-message 1 "gnus-agent-expire: read error \ occurred when reading expression at %s in %s. Skipping to next \ line." (point) nov-file))) - ;; Whether I succeeded, or failed, it doesn't matter. - ;; Move to the next line then try again. - (forward-line 1))) - - (gnus-message - 7 "gnus-agent-expire: Loading overview... Done")) - (set-buffer-modified-p nil) - - ;; At this point, all of the information is in dlist. The - ;; only problem is that much of it is spread across multiple - ;; entries. Sort then MERGE!! - (gnus-message 7 "gnus-agent-expire: Sorting entries... ") - ;; If two entries have the same article-number then sort by - ;; ascending keep_flag. - (let ((special 0) - (marked 1) - (unread 2)) - (setq dlist - (sort dlist - (lambda (a b) - (cond ((< (nth 0 a) (nth 0 b)) - t) - ((> (nth 0 a) (nth 0 b)) - nil) - (t - (let ((a (or (symbol-value (nth 2 a)) - 3)) - (b (or (symbol-value (nth 2 b)) - 3))) - (<= a b)))))))) - (gnus-message 7 "gnus-agent-expire: Sorting entries... Done") - (gnus-message 7 "gnus-agent-expire: Merging entries... ") - (let ((dlist dlist)) - (while (cdr dlist) ; I'm not at the end-of-list - (if (eq (caar dlist) (caadr dlist)) - (let ((first (cdr (car dlist))) - (secnd (cdr (cadr dlist)))) - (setcar first (or (car first) - (car secnd))) ; fetch_date - (setq first (cdr first) - secnd (cdr secnd)) - (setcar first (or (car first) - (car secnd))) ; Keep_flag - (setq first (cdr first) - secnd (cdr secnd)) - (setcar first (or (car first) - (car secnd))) ; NOV_entry_marker - - (setcdr dlist (cddr dlist))) - (setq dlist (cdr dlist))))) - (gnus-message 7 "gnus-agent-expire: Merging entries... Done") - - (let* ((len (float (length dlist))) - (alist (list nil)) - (tail-alist alist)) - (while dlist - (let ((new-completed (truncate (* 100.0 - (/ (setq cnt (1+ cnt)) - len)))) + ;; Whether I succeeded, or failed, it doesn't matter. + ;; Move to the next line then try again. + (forward-line 1))) + + (gnus-message + 7 "gnus-agent-expire: Loading overview... Done")) + (set-buffer-modified-p nil) + + ;; At this point, all of the information is in dlist. The + ;; only problem is that much of it is spread across multiple + ;; entries. Sort then MERGE!! + (gnus-message 7 "gnus-agent-expire: Sorting entries... ") + ;; If two entries have the same article-number then sort by + ;; ascending keep_flag. + (let ((special 0) + (marked 1) + (unread 2)) + (setq dlist + (sort dlist + (lambda (a b) + (cond ((< (nth 0 a) (nth 0 b)) + t) + ((> (nth 0 a) (nth 0 b)) + nil) + (t + (let ((a (or (symbol-value (nth 2 a)) + 3)) + (b (or (symbol-value (nth 2 b)) + 3))) + (<= a b)))))))) + (gnus-message 7 "gnus-agent-expire: Sorting entries... Done") + (gnus-message 7 "gnus-agent-expire: Merging entries... ") + (let ((dlist dlist)) + (while (cdr dlist) ; I'm not at the end-of-list + (if (eq (caar dlist) (caadr dlist)) + (let ((first (cdr (car dlist))) + (secnd (cdr (cadr dlist)))) + (setcar first (or (car first) + (car secnd))) ; fetch_date + (setq first (cdr first) + secnd (cdr secnd)) + (setcar first (or (car first) + (car secnd))) ; Keep_flag + (setq first (cdr first) + secnd (cdr secnd)) + (setcar first (or (car first) + (car secnd))) ; NOV_entry_marker + + (setcdr dlist (cddr dlist))) + (setq dlist (cdr dlist))))) + (gnus-message 7 "gnus-agent-expire: Merging entries... Done") + + (let* ((len (float (length dlist))) + (alist (list nil)) + (tail-alist alist)) + (while dlist + (let ((new-completed (truncate (* 100.0 + (/ (setq cnt (1+ cnt)) + len)))) message-log-max) - (when (> new-completed completed) - (setq completed new-completed) - (gnus-message 7 "%3d%% completed..." completed))) - (let* ((entry (car dlist)) - (article-number (nth 0 entry)) - (fetch-date (nth 1 entry)) - (keep (nth 2 entry)) - (marker (nth 3 entry))) - - (cond - ;; Kept articles are unread, marked, or special. - (keep - (gnus-agent-message 10 - "gnus-agent-expire: %s:%d: Kept %s article%s." - group article-number keep (if fetch-date " and file" "")) - (when fetch-date - (unless (file-exists-p - (concat dir (number-to-string - article-number))) - (setf (nth 1 entry) nil) - (gnus-agent-message 3 "gnus-agent-expire cleared \ + (when (> new-completed completed) + (setq completed new-completed) + (gnus-message 7 "%3d%% completed..." completed))) + (let* ((entry (car dlist)) + (article-number (nth 0 entry)) + (fetch-date (nth 1 entry)) + (keep (nth 2 entry)) + (marker (nth 3 entry))) + + (cond + ;; Kept articles are unread, marked, or special. + (keep + (gnus-agent-message 10 + "gnus-agent-expire: %s:%d: Kept %s article%s." + group article-number keep (if fetch-date " and file" "")) + (when fetch-date + (unless (file-exists-p + (concat dir (number-to-string + article-number))) + (setf (nth 1 entry) nil) + (gnus-agent-message 3 "gnus-agent-expire cleared \ download flag on %s:%d as the cached article file is missing." - group (caar dlist))) - (unless marker - (gnus-message 1 "gnus-agent-expire detected a \ + group (caar dlist))) + (unless marker + (gnus-message 1 "gnus-agent-expire detected a \ missing NOV entry. Run gnus-agent-regenerate-group to restore it."))) - (gnus-agent-append-to-list - tail-alist - (cons article-number fetch-date))) - - ;; The following articles are READ, UNMARKED, and - ;; ORDINARY. See if they can be EXPIRED!!! - ((setq type - (cond - ((not (integerp fetch-date)) - 'read) ;; never fetched article (may expire - ;; right now) - ((not (file-exists-p - (concat dir (number-to-string - article-number)))) - (setf (nth 1 entry) nil) - 'externally-expired) ;; Can't find the cached - ;; article. Handle case - ;; as though this article - ;; was never fetched. - - ;; We now have the arrival day, so we see - ;; whether it's old enough to be expired. - ((< fetch-date day) - 'expired) - (force - 'forced))) - - ;; I found some reason to expire this entry. - - (let ((actions nil)) - (when (memq type '(forced expired)) - (ignore-errors ; Just being paranoid. - (let ((file-name (concat dir (number-to-string - article-number)))) - (incf (nth 2 stats) (nth 7 (file-attributes file-name))) - (incf (nth 1 stats)) - (delete-file file-name)) - (push "expired cached article" actions)) - (setf (nth 1 entry) nil) - ) - - (when marker - (push "NOV entry removed" actions) - (goto-char marker) - - (incf (nth 0 stats)) - - (let ((from (gnus-point-at-bol)) - (to (progn (forward-line 1) (point)))) - (incf (nth 2 stats) (- to from)) - (delete-region from to))) - - ;; If considering all articles is set, I can only - ;; expire article IDs that are no longer in the - ;; active range (That is, articles that preceed the - ;; first article in the new alist). - (if (and gnus-agent-consider-all-articles - (>= article-number (car active))) - ;; I have to keep this ID in the alist - (gnus-agent-append-to-list - tail-alist (cons article-number fetch-date)) - (push (format "Removed %s article number from \ + (gnus-agent-append-to-list + tail-alist + (cons article-number fetch-date))) + + ;; The following articles are READ, UNMARKED, and + ;; ORDINARY. See if they can be EXPIRED!!! + ((setq type + (cond + ((not (integerp fetch-date)) + 'read) ;; never fetched article (may expire + ;; right now) + ((not (file-exists-p + (concat dir (number-to-string + article-number)))) + (setf (nth 1 entry) nil) + 'externally-expired) ;; Can't find the cached + ;; article. Handle case + ;; as though this article + ;; was never fetched. + + ;; We now have the arrival day, so we see + ;; whether it's old enough to be expired. + ((< fetch-date day) + 'expired) + (force + 'forced))) + + ;; I found some reason to expire this entry. + + (let ((actions nil)) + (when (memq type '(forced expired)) + (ignore-errors ; Just being paranoid. + (let* ((file-name (nnheader-concat dir (number-to-string + article-number))) + (size (float (nth 7 (file-attributes file-name))))) + (incf bytes-freed size) + (incf files-deleted) + (delete-file file-name)) + (push "expired cached article" actions)) + (setf (nth 1 entry) nil) + ) + + (when marker + (push "NOV entry removed" actions) + (goto-char marker) + + (incf nov-entries-deleted) + + (let ((from (gnus-point-at-bol)) + (to (progn (forward-line 1) (point)))) + (incf bytes-freed (- to from)) + (delete-region from to))) + + ;; If considering all articles is set, I can only + ;; expire article IDs that are no longer in the + ;; active range (That is, articles that preceed the + ;; first article in the new alist). + (if (and gnus-agent-consider-all-articles + (>= article-number (car active))) + ;; I have to keep this ID in the alist + (gnus-agent-append-to-list + tail-alist (cons article-number fetch-date)) + (push (format "Removed %s article number from \ article alist" type) actions)) (when actions (gnus-agent-message 8 "gnus-agent-expire: %s:%d: %s" group article-number (mapconcat 'identity actions ", "))))) - (t - (gnus-agent-message - 10 "gnus-agent-expire: %s:%d: Article kept as \ + (t + (gnus-agent-message + 10 "gnus-agent-expire: %s:%d: Article kept as \ expiration tests failed." group article-number) - (gnus-agent-append-to-list - tail-alist (cons article-number fetch-date))) - ) - - ;; Clean up markers as I want to recycle this buffer - ;; over several groups. - (when marker - (set-marker marker nil)) - - (setq dlist (cdr dlist)))) - - (setq alist (cdr alist)) - - (let ((inhibit-quit t)) - (unless (equal alist gnus-agent-article-alist) - (setq gnus-agent-article-alist alist) - (gnus-agent-save-alist group)) - - (when (buffer-modified-p) - (let ((coding-system-for-write - gnus-agent-file-coding-system)) - (gnus-make-directory dir) - (write-region (point-min) (point-max) nov-file nil - 'silent) - ;; clear the modified flag as that I'm not confused by - ;; its status on the next pass through this routine. - (set-buffer-modified-p nil))) - - (when (eq articles t) - (gnus-summary-update-info)))))))) + (gnus-agent-append-to-list + tail-alist (cons article-number fetch-date))) + ) + + ;; Clean up markers as I want to recycle this buffer + ;; over several groups. + (when marker + (set-marker marker nil)) + + (setq dlist (cdr dlist)))) + + (setq alist (cdr alist)) + + (let ((inhibit-quit t)) + (unless (equal alist gnus-agent-article-alist) + (setq gnus-agent-article-alist alist) + (gnus-agent-save-alist group)) + + (when (buffer-modified-p) + (let ((coding-system-for-write + gnus-agent-file-coding-system)) + (gnus-make-directory dir) + (write-region (point-min) (point-max) nov-file nil + 'silent) + ;; clear the modified flag as that I'm not confused by + ;; its status on the next pass through this routine. + (set-buffer-modified-p nil))) + + (when (eq articles t) + (gnus-summary-update-info)))) + + (when (boundp 'gnus-agent-expire-stats) + (let ((stats (symbol-value 'gnus-agent-expire-stats))) + (incf (nth 2 stats) bytes-freed) + (incf (nth 1 stats) files-deleted) + (incf (nth 0 stats) nov-entries-deleted))) + )))) (defun gnus-agent-expire (&optional articles group force) "Expire all old articles. @@ -3248,7 +3472,7 @@ articles in every agentized group.")) (defun gnus-agent-uncached-articles (articles group &optional cached-header) "Restrict ARTICLES to numbers already fetched. -Returns a sublist of ARTICLES that excludes thos article ids in GROUP +Returns a sublist of ARTICLES that excludes those article ids in GROUP that have already been fetched. If CACHED-HEADER is nil, articles are only excluded if the article itself has been fetched." @@ -3338,12 +3562,11 @@ has been fetched." ;; Get the list of articles that were fetched (goto-char (point-min)) - (let ((pm (point-max))) + (let ((pm (point-max)) + art) (while (< (point) pm) - (when (looking-at "[0-9]+\t") - (gnus-agent-append-to-list - tail-fetched-articles - (read (current-buffer)))) + (when (setq art (gnus-agent-read-article-number)) + (gnus-agent-append-to-list tail-fetched-articles art)) (forward-line 1))) ;; Clip this list to the headers that will @@ -3380,12 +3603,12 @@ has been fetched." (set-buffer nntp-server-buffer) (copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max)) - ;; Merge the temp buffer with the known headers (found on - ;; disk in FILE) into the nntp-server-buffer - (when (and uncached-articles (file-exists-p file)) + ;; Merge the temp buffer with the known headers (found on + ;; disk in FILE) into the nntp-server-buffer + (when uncached-articles (gnus-agent-braid-nov group uncached-articles file)) - ;; Save the new set of known headers to FILE + ;; Save the new set of known headers to FILE (set-buffer nntp-server-buffer) (let ((coding-system-for-write gnus-agent-file-coding-system)) @@ -3465,7 +3688,6 @@ If REREAD is not nil, downloaded articles are marked as unread." (gnus-message 3 "Ignoring unexpected input") (sit-for 1) t))))) - (when group (gnus-message 5 "Regenerating in %s" group) (let* ((gnus-command-method (or gnus-command-method @@ -3506,7 +3728,7 @@ If REREAD is not nil, downloaded articles are marked as unread." (gnus-delete-line) (setq nov-arts (cdr nov-arts)) (gnus-message 4 "gnus-agent-regenerate-group: NOV\ -entry of article %s deleted." l1)) + entry of article %s deleted." l1)) ((not l2) nil) ((< l1 l2) @@ -3651,10 +3873,9 @@ entry of article %s deleted." l1)) gnus-agent-article-alist)))) (when (gnus-buffer-live-p gnus-group-buffer) - (gnus-group-update-group group t) - (sit-for 0))) + (gnus-group-update-group group t))) - (gnus-message 5 nil) + (gnus-message 5 "") regenerated))) ;;;###autoload @@ -3700,49 +3921,6 @@ If CLEAN, obsolete (ignore)." (defun gnus-agent-group-covered-p (group) (gnus-agent-method-p (gnus-group-method group))) -(add-hook 'gnus-group-prepare-hook - (lambda () - 'gnus-agent-do-once - - (when (listp gnus-agent-expire-days) - (beep) - (beep) - (gnus-message 1 "WARNING: gnus-agent-expire-days no longer\ - supports being set to a list.")(sleep-for 3) - (gnus-message 1 "Change your configuration to set it to an\ - integer.")(sleep-for 3) - (gnus-message 1 "I am now setting group parameters on each\ - group to match the configuration that the list offered.") - - (save-excursion - (let ((groups (gnus-group-listed-groups))) - (while groups - (let* ((group (pop groups)) - (days gnus-agent-expire-days) - (day (catch 'found - (while days - (when (eq 0 (string-match - (caar days) - group)) - (throw 'found (cadar days))) - (setq days (cdr days))) - nil))) - (when day - (gnus-group-set-parameter group 'agent-days-until-old - day)))))) - - (let ((h gnus-group-prepare-hook)) - (while h - (let ((func (pop h))) - (when (and (listp func) - (eq (cadr (caddr func)) 'gnus-agent-do-once)) - (remove-hook 'gnus-group-prepare-hook func) - (setq h nil))))) - - (gnus-message 1 "I have finished setting group parameters on\ - each group. You may now customize your groups and/or topics to control the\ - agent.")))) - (provide 'gnus-agent) ;;; arch-tag: b0ba4afc-5229-4cee-ad25-9956daa4e91e diff --git a/lisp/gnus/gnus-cache.el b/lisp/gnus/gnus-cache.el index 99e77b18f68..f0a5aa318fd 100644 --- a/lisp/gnus/gnus-cache.el +++ b/lisp/gnus/gnus-cache.el @@ -726,6 +726,46 @@ If GROUP is non-nil, also cater to `gnus-cacheable-groups' and (or (not gnus-uncacheable-groups) (not (string-match gnus-uncacheable-groups group))))))) +;;;###autoload +(defun gnus-cache-rename-group (old-group new-group) + "Rename OLD-GROUP as NEW-GROUP. Always updates the cache, even when +disabled, as the old cache files would corrupt gnus when the cache was +next enabled. Depends upon the caller to determine whether group renaming is supported." + (let ((old-dir (gnus-cache-file-name old-group "")) + (new-dir (gnus-cache-file-name new-group ""))) + (gnus-rename-file old-dir new-dir t)) + + (let ((no-save gnus-cache-active-hashtb)) + (unless gnus-cache-active-hashtb + (gnus-cache-read-active)) + (let* ((old-group-hash-value (gnus-gethash old-group gnus-cache-active-hashtb)) + (new-group-hash-value (gnus-gethash new-group gnus-cache-active-hashtb)) + (delta (or old-group-hash-value new-group-hash-value))) + (gnus-sethash new-group old-group-hash-value gnus-cache-active-hashtb) + (gnus-sethash old-group nil gnus-cache-active-hashtb) + + (if no-save + (setq gnus-cache-active-altered delta) + (gnus-cache-write-active delta))))) + +;;;###autoload +(defun gnus-cache-delete-group (group) + "Delete GROUP. Always updates the cache, even when +disabled, as the old cache files would corrupt gnus when the cache was +next enabled. Depends upon the caller to determine whether group deletion is supported." + (let ((dir (gnus-cache-file-name group ""))) + (gnus-delete-file dir)) + + (let ((no-save gnus-cache-active-hashtb)) + (unless gnus-cache-active-hashtb + (gnus-cache-read-active)) + (let* ((group-hash-value (gnus-gethash group gnus-cache-active-hashtb))) + (gnus-sethash group nil gnus-cache-active-hashtb) + + (if no-save + (setq gnus-cache-active-altered group-hash-value) + (gnus-cache-write-active group-hash-value))))) + (provide 'gnus-cache) ;;; arch-tag: 05a79442-8c58-4e65-bd0a-3cbb1b89a33a diff --git a/lisp/gnus/gnus-draft.el b/lisp/gnus/gnus-draft.el index 62deeb4b894..15bb3bc3544 100644 --- a/lisp/gnus/gnus-draft.el +++ b/lisp/gnus/gnus-draft.el @@ -132,17 +132,21 @@ (defun gnus-draft-send (article &optional group interactive) "Send message ARTICLE." - (let ((message-syntax-checks (if interactive message-syntax-checks - 'dont-check-for-anything-just-trust-me)) - (message-hidden-headers nil) - (message-inhibit-body-encoding (or (not group) - (equal group "nndraft:queue") - message-inhibit-body-encoding)) - (message-send-hook (and group (not (equal group "nndraft:queue")) - message-send-hook)) - (message-setup-hook (and group (not (equal group "nndraft:queue")) - message-setup-hook)) - type method move-to) + (let* ((is-queue (or (not group) + (equal group "nndraft:queue"))) + (message-syntax-checks (if interactive message-syntax-checks + 'dont-check-for-anything-just-trust-me)) + (message-hidden-headers nil) + (message-inhibit-body-encoding (or is-queue + message-inhibit-body-encoding)) + (message-send-hook (and (not is-queue) + message-send-hook)) + (message-setup-hook (and (not is-queue) + message-setup-hook)) + (gnus-agent-queue-mail (and (not is-queue) + gnus-agent-queue-mail)) + (rfc2047-encode-encoded-words nil) + type method move-to) (gnus-draft-setup article (or group "nndraft:queue")) ;; We read the meta-information that says how and where ;; this message is to be sent. @@ -196,22 +200,25 @@ (defun gnus-group-send-queue () "Send all sendable articles from the queue group." (interactive) - (gnus-activate-group "nndraft:queue") - (save-excursion - (let* ((articles (nndraft-articles)) - (unsendable (gnus-uncompress-range - (cdr (assq 'unsend - (gnus-info-marks - (gnus-get-info "nndraft:queue")))))) - (gnus-posting-styles nil) - (total (length articles)) - article) - (while (setq article (pop articles)) - (unless (memq article unsendable) - (let ((message-sending-message - (format "Sending message %d of %d..." - (- total (length articles)) total))) - (gnus-draft-send article))))))) + (when (or gnus-plugged + (not gnus-agent-prompt-send-queue) + (gnus-y-or-n-p "Gnus is unplugged; really send queue? ")) + (gnus-activate-group "nndraft:queue") + (save-excursion + (let* ((articles (nndraft-articles)) + (unsendable (gnus-uncompress-range + (cdr (assq 'unsend + (gnus-info-marks + (gnus-get-info "nndraft:queue")))))) + (gnus-posting-styles nil) + (total (length articles)) + article) + (while (setq article (pop articles)) + (unless (memq article unsendable) + (let ((message-sending-message + (format "Sending message %d of %d..." + (- total (length articles)) total))) + (gnus-draft-send article)))))))) ;;;###autoload (defun gnus-draft-reminder () @@ -265,12 +272,13 @@ `(lambda (arg) (gnus-post-method arg ,(car ga)))) (unless (equal (cadr ga) "") - (message-add-action - `(progn - (gnus-add-mark ,(car ga) 'replied ,(cadr ga)) - (gnus-request-set-mark ,(car ga) (list (list (list ,(cadr ga)) - 'add '(reply))))) - 'send)))))) + (dolist (article (cdr ga)) + (message-add-action + `(progn + (gnus-add-mark ,(car ga) 'replied ,article) + (gnus-request-set-mark ,(car ga) (list (list (list ,article) + 'add '(reply))))) + 'send))))))) (defun gnus-draft-article-sendable-p (article) "Say whether ARTICLE is sendable." diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index bff4ba19a6f..f3b2f91cd5e 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -44,13 +44,13 @@ (eval-when-compile (require 'mm-url)) (defcustom gnus-group-archive-directory - "*ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list/" + "/ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list/" "*The address of the (ding) archives." :group 'gnus-group-foreign :type 'directory) (defcustom gnus-group-recent-archive-directory - "*ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list-recent/" + "/ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list-recent/" "*The address of the most recent (ding) articles." :group 'gnus-group-foreign :type 'directory) @@ -2283,8 +2283,6 @@ ADDRESS." (lambda (group) (gnus-group-delete-group group nil t)))))) -(defvar gnus-cache-active-altered) - (defun gnus-group-delete-group (group &optional force no-prompt) "Delete the current group. Only meaningful with editable groups. If FORCE (the prefix) is non-nil, all the articles in the group will @@ -2314,10 +2312,6 @@ be removed from the server, even when it's empty." (gnus-group-goto-group group) (gnus-group-kill-group 1 t) (gnus-sethash group nil gnus-active-hashtb) - (if (boundp 'gnus-cache-active-hashtb) - (when gnus-cache-active-hashtb - (gnus-sethash group nil gnus-cache-active-hashtb) - (setq gnus-cache-active-altered t))) t)) (gnus-group-position-point))) @@ -3133,7 +3127,7 @@ or nil if no action could be taken." (let* ((entry (gnus-gethash group gnus-newsrc-hashtb)) (num (car entry)) (marks (nth 3 (nth 2 entry))) - (unread (gnus-list-of-unread-articles group))) + (unread (gnus-sequence-of-unread-articles group))) ;; Remove entries for this group. (nnmail-purge-split-history (gnus-group-real-name group)) ;; Do the updating only if the newsgroup isn't killed. @@ -3146,16 +3140,17 @@ or nil if no action could be taken." 'del '(tick)) (list (cdr (assq 'dormant marks)) 'del '(dormant)))) - (setq unread (gnus-uncompress-range - (gnus-range-add (gnus-range-add - unread (cdr (assq 'dormant marks))) - (cdr (assq 'tick marks))))) + (setq unread (gnus-range-add (gnus-range-add + unread (cdr (assq 'dormant marks))) + (cdr (assq 'tick marks)))) (gnus-add-marked-articles group 'tick nil nil 'force) (gnus-add-marked-articles group 'dormant nil nil 'force)) ;; Do auto-expirable marks if that's required. (when (gnus-group-auto-expirable-p group) - (gnus-add-marked-articles group 'expire unread) - (gnus-request-set-mark group (list (list unread 'add '(expire))))) + (gnus-range-map (lambda (article) + (gnus-add-marked-articles group 'expire (list article)) + (gnus-request-set-mark group (list (list (list article) 'add '(expire))))) + unread)) (let ((gnus-newsgroup-name group)) (gnus-run-hooks 'gnus-group-catchup-group-hook)) num))) @@ -3517,7 +3512,7 @@ entail asking the server for the groups." ;; First we make sure that we have really read the active file. (unless (gnus-read-active-file-p) (let ((gnus-read-active-file t) - (gnus-agent nil)) ; Trick the agent into ignoring the active file. + (gnus-agent gnus-plugged)); If we're actually plugged, store the active file in the agent. (gnus-read-active-file))) ;; Find all groups and sort them. (let ((groups diff --git a/lisp/gnus/gnus-int.el b/lisp/gnus/gnus-int.el index 2363c2705cb..7382fa7a090 100644 --- a/lisp/gnus/gnus-int.el +++ b/lisp/gnus/gnus-int.el @@ -33,6 +33,7 @@ (require 'gnus-range) (autoload 'gnus-agent-expire "gnus-agent") +(autoload 'gnus-agent-regenerate-group "gnus-agent") (autoload 'gnus-agent-read-servers-validate-native "gnus-agent") (defcustom gnus-open-server-hook nil @@ -176,7 +177,7 @@ If it is down, start it up (again)." (setq method (gnus-server-to-method method))) ;; Check cache of constructed names. (let* ((method-sym (if gnus-agent - (gnus-agent-get-function method) + (inline (gnus-agent-get-function method)) (car method))) (method-fns (get method-sym 'gnus-method-functions)) (func (let ((method-fnlist-elt (assq function method-fns))) @@ -570,7 +571,7 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." (nth 1 gnus-command-method) accept-function last))) (when (and result gnus-agent (gnus-agent-method-p gnus-command-method)) - (gnus-agent-expire (list article) group 'force)) + (gnus-agent-unfetch-articles group (list article))) result)) (defun gnus-request-accept-article (group &optional gnus-command-method last @@ -580,7 +581,8 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." (setq gnus-command-method (gnus-server-to-method gnus-command-method))) (when (and (not gnus-command-method) (stringp group)) - (setq gnus-command-method (gnus-group-name-to-method group))) + (setq gnus-command-method (or (gnus-find-method-for-group group) + (gnus-group-name-to-method group)))) (goto-char (point-max)) (unless (bolp) (insert "\n")) @@ -592,12 +594,17 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." (let ((mail-parse-charset message-default-charset)) (mail-encode-encoded-word-buffer))) (message-encode-message-body))) - (let ((gnus-command-method (or gnus-command-method - (gnus-find-method-for-group group)))) - (funcall (gnus-get-function gnus-command-method 'request-accept-article) - (if (stringp group) (gnus-group-real-name group) group) - (cadr gnus-command-method) - last))) +(let ((gnus-command-method (or gnus-command-method + (gnus-find-method-for-group group))) + (result + (funcall + (gnus-get-function gnus-command-method 'request-accept-article) + (if (stringp group) (gnus-group-real-name group) group) + (cadr gnus-command-method) + last))) + (when (and gnus-agent (gnus-agent-method-p gnus-command-method)) + (gnus-agent-regenerate-group group (list (cdr result)))) + result)) (defun gnus-request-replace-article (article group buffer &optional no-encode) (unless no-encode @@ -608,9 +615,12 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." (let ((mail-parse-charset message-default-charset)) (mail-encode-encoded-word-buffer))) (message-encode-message-body))) - (let ((func (car (gnus-group-name-to-method group)))) - (funcall (intern (format "%s-request-replace-article" func)) - article (gnus-group-real-name group) buffer))) + (let* ((func (car (gnus-group-name-to-method group))) + (result (funcall (intern (format "%s-request-replace-article" func)) + article (gnus-group-real-name group) buffer))) + (when (and gnus-agent (gnus-agent-method-p gnus-command-method)) + (gnus-agent-regenerate-group group (list article))) + result)) (defun gnus-request-associate-buffer (group) (let ((gnus-command-method (gnus-find-method-for-group group))) @@ -633,15 +643,25 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." (gnus-group-real-name group) (nth 1 gnus-command-method) args))) (defun gnus-request-delete-group (group &optional force) - (let ((gnus-command-method (gnus-find-method-for-group group))) - (funcall (gnus-get-function gnus-command-method 'request-delete-group) - (gnus-group-real-name group) force (nth 1 gnus-command-method)))) + (let* ((gnus-command-method (gnus-find-method-for-group group)) + (result + (funcall (gnus-get-function gnus-command-method 'request-delete-group) + (gnus-group-real-name group) force (nth 1 gnus-command-method)))) + (when result + (gnus-cache-delete-group group) + (gnus-agent-delete-group group)) + result)) (defun gnus-request-rename-group (group new-name) - (let ((gnus-command-method (gnus-find-method-for-group group))) - (funcall (gnus-get-function gnus-command-method 'request-rename-group) - (gnus-group-real-name group) - (gnus-group-real-name new-name) (nth 1 gnus-command-method)))) + (let* ((gnus-command-method (gnus-find-method-for-group group)) + (result + (funcall (gnus-get-function gnus-command-method 'request-rename-group) + (gnus-group-real-name group) + (gnus-group-real-name new-name) (nth 1 gnus-command-method)))) + (when result + (gnus-cache-rename-group group new-name) + (gnus-agent-rename-group group new-name)) + result)) (defun gnus-close-backends () ;; Send a close request to all backends that support such a request. diff --git a/lisp/gnus/gnus-range.el b/lisp/gnus/gnus-range.el index 56a1b569418..d2442c63a42 100644 --- a/lisp/gnus/gnus-range.el +++ b/lisp/gnus/gnus-range.el @@ -1,6 +1,6 @@ ;;; gnus-range.el --- range and sequence functions for Gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002 +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2004 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> @@ -184,6 +184,58 @@ LIST1 and LIST2 have to be sorted over <." (nreverse out))) ;;;###autoload +(defun gnus-sorted-range-intersection (range1 range2) + "Return intersection of RANGE1 and RANGE2. +RANGE1 and RANGE2 have to be sorted over <." + (let* (out + (min1 (car range1)) + (max1 (if (numberp min1) + (if (numberp (cdr range1)) + (prog1 (cdr range1) + (setq range1 nil)) min1) + (prog1 (cdr min1) + (setq min1 (car min1))))) + (min2 (car range2)) + (max2 (if (numberp min2) + (if (numberp (cdr range2)) + (prog1 (cdr range2) + (setq range2 nil)) min2) + (prog1 (cdr min2) + (setq min2 (car min2)))))) + (setq range1 (cdr range1) + range2 (cdr range2)) + (while (and min1 min2) + (cond ((< max1 min2) ; range1 preceeds range2 + (setq range1 (cdr range1) + min1 nil)) + ((< max2 min1) ; range2 preceeds range1 + (setq range2 (cdr range2) + min2 nil)) + (t ; some sort of overlap is occurring + (let ((min (max min1 min2)) + (max (min max1 max2))) + (setq out (if (= min max) + (cons min out) + (cons (cons min max) out)))) + (if (< max1 max2) ; range1 ends before range2 + (setq min1 nil) ; incr range1 + (setq min2 nil)))) ; incr range2 + (unless min1 + (setq min1 (car range1) + max1 (if (numberp min1) min1 (prog1 (cdr min1) (setq min1 (car min1)))) + range1 (cdr range1))) + (unless min2 + (setq min2 (car range2) + max2 (if (numberp min2) min2 (prog1 (cdr min2) (setq min2 (car min2)))) + range2 (cdr range2)))) + (cond ((cdr out) + (nreverse out)) + ((numberp (car out)) + out) + (t + (car out))))) + +;;;###autoload (defalias 'gnus-set-sorted-intersection 'gnus-sorted-nintersection) ;;;###autoload @@ -589,6 +641,19 @@ LIST is a sorted list." (setcdr prev (cons num list))) (cdr top))) +(defun gnus-range-map (func range) + "Apply FUNC to each value contained by RANGE." + (setq range (gnus-range-normalize range)) + (while range + (let ((span (pop range))) + (if (numberp span) + (funcall func span) + (let ((first (car span)) + (last (cdr span))) + (while (<= first last) + (funcall func first) + (setq first (1+ first)))))))) + (provide 'gnus-range) ;;; arch-tag: 4780bdd8-5a15-4aff-be28-18727895b6ad diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el index ced7921437f..67d86fef02a 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -1,5 +1,5 @@ ;;; gnus-start.el --- startup functions for Gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> @@ -34,8 +34,15 @@ (require 'gnus-util) (autoload 'message-make-date "message") (autoload 'gnus-agent-read-servers-validate "gnus-agent") +(autoload 'gnus-agent-save-local "gnus-agent") (autoload 'gnus-agent-possibly-alter-active "gnus-agent") -(eval-when-compile (require 'cl)) + +(eval-when-compile + (require 'cl) + + (defvar gnus-agent-covered-methods nil) + (defvar gnus-agent-file-loading-local nil) + (defvar gnus-agent-file-loading-cache nil)) (defcustom gnus-startup-file (nnheader-concat gnus-home-directory ".newsrc") "Your `.newsrc' file. @@ -663,6 +670,8 @@ the first newsgroup." (setq gnus-list-of-killed-groups nil gnus-have-read-active-file nil gnus-agent-covered-methods nil + gnus-agent-file-loading-local nil + gnus-agent-file-loading-cache nil gnus-server-method-cache nil gnus-newsrc-alist nil gnus-newsrc-hashtb nil @@ -1511,12 +1520,21 @@ If SCAN, request a scan of that group as well." (gnus-active group)) (gnus-active group) + ;; If a cache is present, we may have to alter the active info. + (when gnus-use-cache + (inline (gnus-cache-possibly-alter-active + group active))) + + ;; If the agent is enabled, we may have to alter the active info. + (when gnus-agent + (gnus-agent-possibly-alter-active group active)) + (gnus-set-active group active) ;; Return the new active info. active))))) (defun gnus-get-unread-articles-in-group (info active &optional update) - (when active + (when (and info active) ;; Allow the backend to update the info in the group. (when (and update (gnus-request-update-info @@ -1526,6 +1544,10 @@ If SCAN, request a scan of that group as well." (let* ((range (gnus-info-read info)) (num 0)) + + ;; These checks are present in gnus-activate-group but skipped + ;; due to setting dont-check in the preceeding call. + ;; If a cache is present, we may have to alter the active info. (when (and gnus-use-cache info) (inline (gnus-cache-possibly-alter-active @@ -1533,8 +1555,7 @@ If SCAN, request a scan of that group as well." ;; If the agent is enabled, we may have to alter the active info. (when (and gnus-agent info) - (gnus-agent-possibly-alter-active - (gnus-info-group info) active)) + (gnus-agent-possibly-alter-active (gnus-info-group info) active info)) ;; Modify the list of read articles according to what articles ;; are available; then tally the unread articles and add the @@ -1630,7 +1651,7 @@ If SCAN, request a scan of that group as well." (while newsrc (setq active (gnus-active (setq group (gnus-info-group - (setq info (pop newsrc)))))) + (setq info (pop newsrc)))))) ;; Check newsgroups. If the user doesn't want to check them, or ;; they can't be checked (for instance, if the news server can't @@ -1653,61 +1674,60 @@ If SCAN, request a scan of that group as well." (when (and method (not (setq method-type (cdr (assoc method type-cache))))) (setq method-type - (cond - ((gnus-secondary-method-p method) - 'secondary) - ((inline (gnus-server-equal gnus-select-method method)) - 'primary) - (t - 'foreign))) + (cond + ((gnus-secondary-method-p method) + 'secondary) + ((inline (gnus-server-equal gnus-select-method method)) + 'primary) + (t + 'foreign))) (push (cons method method-type) type-cache)) - (if (and method - (eq method-type 'foreign)) - ;; These groups are foreign. Check the level. - (when (and (<= (gnus-info-level info) foreign-level) - (setq active (gnus-activate-group group 'scan))) - ;; Let the Gnus agent save the active file. - (when (and gnus-agent active (gnus-online method)) - (gnus-agent-save-group-info - method (gnus-group-real-name group) active)) - (unless (inline (gnus-virtual-group-p group)) - (inline (gnus-close-group group))) - (when (fboundp (intern (concat (symbol-name (car method)) - "-request-update-info"))) - (inline (gnus-request-update-info info method)))) - ;; These groups are native or secondary. - (cond - ;; We don't want these groups. - ((> (gnus-info-level info) level) - (setq active 'ignore)) - ;; Activate groups. - ((not gnus-read-active-file) - (if (gnus-check-backend-function 'retrieve-groups group) - ;; if server support gnus-retrieve-groups we push - ;; the group onto retrievegroups for later checking - (if (assoc method retrieve-groups) - (setcdr (assoc method retrieve-groups) - (cons group (cdr (assoc method retrieve-groups)))) - (push (list method group) retrieve-groups)) - ;; hack: `nnmail-get-new-mail' changes the mail-source depending - ;; on the group, so we must perform a scan for every group - ;; if the users has any directory mail sources. - ;; hack: if `nnmail-scan-directory-mail-source-once' is non-nil, - ;; for it scan all spool files even when the groups are - ;; not required. - (if (and - (or nnmail-scan-directory-mail-source-once - (null (assq 'directory - (or mail-sources - (if (listp nnmail-spool-file) - nnmail-spool-file - (list nnmail-spool-file)))))) - (member method scanned-methods)) - (setq active (gnus-activate-group group)) - (setq active (gnus-activate-group group 'scan)) - (push method scanned-methods)) - (when active - (gnus-close-group group)))))) + + (cond ((and method (eq method-type 'foreign)) + ;; These groups are foreign. Check the level. + (when (and (<= (gnus-info-level info) foreign-level) + (setq active (gnus-activate-group group 'scan))) + ;; Let the Gnus agent save the active file. + (when (and gnus-agent active (gnus-online method)) + (gnus-agent-save-group-info + method (gnus-group-real-name group) active)) + (unless (inline (gnus-virtual-group-p group)) + (inline (gnus-close-group group))) + (when (fboundp (intern (concat (symbol-name (car method)) + "-request-update-info"))) + (inline (gnus-request-update-info info method))))) + ;; These groups are native or secondary. + ((> (gnus-info-level info) level) + ;; We don't want these groups. + (setq active 'ignore)) + ;; Activate groups. + ((not gnus-read-active-file) + (if (gnus-check-backend-function 'retrieve-groups group) + ;; if server support gnus-retrieve-groups we push + ;; the group onto retrievegroups for later checking + (if (assoc method retrieve-groups) + (setcdr (assoc method retrieve-groups) + (cons group (cdr (assoc method retrieve-groups)))) + (push (list method group) retrieve-groups)) + ;; hack: `nnmail-get-new-mail' changes the mail-source depending + ;; on the group, so we must perform a scan for every group + ;; if the users has any directory mail sources. + ;; hack: if `nnmail-scan-directory-mail-source-once' is non-nil, + ;; for it scan all spool files even when the groups are + ;; not required. + (if (and + (or nnmail-scan-directory-mail-source-once + (null (assq 'directory + (or mail-sources + (if (listp nnmail-spool-file) + nnmail-spool-file + (list nnmail-spool-file)))))) + (member method scanned-methods)) + (setq active (gnus-activate-group group)) + (setq active (gnus-activate-group group 'scan)) + (push method scanned-methods)) + (when active + (gnus-close-group group))))) ;; Get the number of unread articles in the group. (cond @@ -1734,8 +1754,8 @@ If SCAN, request a scan of that group as well." (when (gnus-check-backend-function 'request-scan (car method)) (gnus-request-scan nil method)) (gnus-read-active-file-2 - (mapcar (lambda (group) (gnus-group-real-name group)) groups) - method) + (mapcar (lambda (group) (gnus-group-real-name group)) groups) + method) (dolist (group groups) (cond ((setq active (gnus-active (gnus-info-group @@ -1980,10 +2000,10 @@ If SCAN, request a scan of that group as well." (while (setq info (pop newsrc)) (when (inline (gnus-server-equal - (inline - (gnus-find-method-for-group - (gnus-info-group info) info)) - gmethod)) + (inline + (gnus-find-method-for-group + (gnus-info-group info) info)) + gmethod)) (push (gnus-group-real-name (gnus-info-group info)) groups))) (gnus-read-active-file-2 groups method))) @@ -2127,7 +2147,7 @@ If SCAN, request a scan of that group as well." (gnus-online method) (gnus-agent-method-p method)) (progn - (gnus-agent-save-groups method) + (gnus-agent-save-active method) (gnus-active-to-gnus-format method hashtb nil real-active)) (goto-char (point-min)) @@ -2203,17 +2223,93 @@ If FORCE is non-nil, the .newsrc file is read." (gnus-convert-old-newsrc)))) (defun gnus-convert-old-newsrc () - "Convert old newsrc into the new format, if needed." + "Convert old newsrc formats into the current format, if needed." (let ((fcv (and gnus-newsrc-file-version (gnus-continuum-version gnus-newsrc-file-version)))) - (cond - ;; No .newsrc.eld file was loaded. - ((null fcv) nil) - ;; Gnus 5 .newsrc.eld was loaded. - ((< fcv (gnus-continuum-version "September Gnus v0.1")) - (gnus-convert-old-ticks))))) - -(defun gnus-convert-old-ticks () + (when fcv + ;; A newsrc file was loaded. + (let (prompt-displayed + (converters + (sort + (mapcar (lambda (date-func) + (cons (gnus-continuum-version (car date-func)) + date-func)) + ;; This is a list of converters that must be run + ;; to bring the newsrc file up to the current + ;; version. If you create an incompatibility + ;; with older versions, you should create an + ;; entry here. The entry should consist of the + ;; current gnus version (hardcoded so that it + ;; doesn't change with each release) and the + ;; function that must be applied to convert the + ;; previous version into the current version. + '(("September Gnus v0.1" nil + gnus-convert-old-ticks) + ("Oort Gnus v0.08" "legacy-gnus-agent" + gnus-agent-convert-to-compressed-agentview) + ("No Gnus v0.2" "legacy-gnus-agent" + gnus-agent-unlist-expire-days) + ("No Gnus v0.2" "legacy-gnus-agent" + gnus-agent-unhook-expire-days))) + #'car-less-than-car))) + ;; Skip converters older than the file version + (while (and converters (>= fcv (caar converters))) + (pop converters)) + + ;; Perform converters to bring older version up to date. + (when (and converters (< fcv (caar converters))) + (while (and converters (< fcv (caar converters))) + (let* ((converter-spec (pop converters)) + (convert-to (nth 1 converter-spec)) + (load-from (nth 2 converter-spec)) + (func (nth 3 converter-spec))) + (when (and load-from + (not (fboundp func))) + (load load-from t)) + + (or prompt-displayed + (not (gnus-convert-converter-needs-prompt func)) + (while (let (c + (cursor-in-echo-area t) + (echo-keystrokes 0)) + (message "Convert gnus from version '%s' to '%s'? (n/y/?)" + gnus-newsrc-file-version gnus-version) + (setq c (read-char-exclusive)) + + (cond ((or (eq c ?n) (eq c ?N)) + (error "Can not start gnus without converting")) + ((or (eq c ?y) (eq c ?Y)) + (setq prompt-displayed t) + nil) + ((eq c ?\?) + (message "This conversion is irreversible. \ + To be safe, you should backup your files before proceeding.") + (sit-for 5) + t) + (t + (gnus-message 3 "Ignoring unexpected input") + (sit-for 3) + t))))) + + (funcall func convert-to))) + (gnus-dribble-enter + (format ";Converted gnus from version '%s' to '%s'." + gnus-newsrc-file-version gnus-version))))))) + +(defun gnus-convert-mark-converter-prompt (converter no-prompt) + "Indicate whether CONVERTER requires gnus-convert-old-newsrc to + display the conversion prompt. NO-PROMPT may be nil (prompt), + t (no prompt), or any form that can be called as a function. + The form should return either t or nil." + (put converter 'gnus-convert-no-prompt no-prompt)) + +(defun gnus-convert-converter-needs-prompt (converter) + (let ((no-prompt (get converter 'gnus-convert-no-prompt))) + (not (if (memq no-prompt '(t nil)) + no-prompt + (funcall no-prompt))))) + +(defun gnus-convert-old-ticks (converting-to) (let ((newsrc (cdr gnus-newsrc-alist)) marks info dormant ticked) (while (setq info (pop newsrc)) @@ -2593,6 +2689,10 @@ If FORCE is non-nil, the .newsrc file is read." ;; from the variable gnus-newsrc-alist. (when (and (or gnus-newsrc-alist gnus-killed-list) gnus-current-startup-file) + ;; Save agent range limits for the currently active method. + (when gnus-agent + (gnus-agent-save-local force)) + (save-excursion (if (and (or gnus-use-dribble-file gnus-slave) (not force) @@ -2610,6 +2710,7 @@ If FORCE is non-nil, the .newsrc file is read." (gnus-message 8 "Saving %s..." gnus-current-startup-file) (gnus-gnus-to-newsrc-format) (gnus-message 8 "Saving %s...done" gnus-current-startup-file)) + ;; Save .newsrc.eld. (set-buffer (gnus-get-buffer-create " *Gnus-newsrc*")) (make-local-variable 'version-control) diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index 38877a78192..14ad9c99a3b 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -3234,28 +3234,34 @@ buffer that was in action when the last article was fetched." (save-excursion (gnus-set-work-buffer) (let ((gnus-summary-line-format-spec spec) - (gnus-newsgroup-downloadable '(0))) + (gnus-newsgroup-downloadable '(0)) + marks) + (insert ?\200 "\200" ?\201 "\201" ?\202 "\202" ?\203 "\203") + (while (not (bobp)) + (push (buffer-substring (1- (point)) (point)) marks) + (backward-char)) + (erase-buffer) (gnus-summary-insert-line [0 "" "" "05 Apr 2001 23:33:09 +0400" "" "" 0 0 "" nil] 0 nil t 128 t nil "" nil 1) (goto-char (point-min)) (setq pos (list (cons 'unread - (and (search-forward - (mm-string-as-multibyte "\200") nil t) + (and (or (search-forward (nth 0 marks) nil t) + (search-forward (nth 1 marks) nil t)) (- (point) (point-min) 1))))) (goto-char (point-min)) - (push (cons 'replied (and (search-forward - (mm-string-as-multibyte "\201") nil t) + (push (cons 'replied (and (or (search-forward (nth 2 marks) nil t) + (search-forward (nth 3 marks) nil t)) (- (point) (point-min) 1))) pos) (goto-char (point-min)) - (push (cons 'score (and (search-forward - (mm-string-as-multibyte "\202") nil t) + (push (cons 'score (and (or (search-forward (nth 4 marks) nil t) + (search-forward (nth 5 marks) nil t)) (- (point) (point-min) 1))) pos) (goto-char (point-min)) - (push (cons 'download (and (search-forward - (mm-string-as-multibyte "\203") nil t) + (push (cons 'download (and (or (search-forward (nth 6 marks) nil t) + (search-forward (nth 7 marks) nil t)) (- (point) (point-min) 1))) pos))) (setq gnus-summary-mark-positions pos)))) @@ -5070,17 +5076,8 @@ If SELECT-ARTICLES, only select those articles from GROUP." group (gnus-status-message group))) (when gnus-agent - ;; The agent may be storing articles that are no longer in the - ;; server's active range. If that is the case, the active range - ;; needs to be expanded such that the agent's articles can be - ;; included in the summary. - (let* ((gnus-command-method (gnus-find-method-for-group group)) - (alist (gnus-agent-load-alist group)) - (active (gnus-active group))) - (if (and (car alist) - (< (caar alist) (car active))) - (gnus-set-active group (cons (caar alist) (cdr active))))) - + (gnus-agent-possibly-alter-active group (gnus-active group) info) + (setq gnus-summary-use-undownloaded-faces (gnus-agent-find-parameter group @@ -5409,7 +5406,8 @@ If SELECT-ARTICLES, only select those articles from GROUP." (min (car active)) (max (cdr active)) (types gnus-article-mark-lists) - marks var articles article mark mark-type) + marks var articles article mark mark-type + bgn end) (dolist (marks marked-lists) (setq mark (car marks) @@ -5419,13 +5417,30 @@ If SELECT-ARTICLES, only select those articles from GROUP." ;; We set the variable according to the type of the marks list, ;; and then adjust the marks to a subset of the active articles. (cond - ;; Adjust "simple" lists. + ;; Adjust "simple" lists - compressed yet unsorted ((eq mark-type 'list) - (set var (setq articles (gnus-uncompress-range (cdr marks)))) - (when (memq mark '(tick dormant expire reply save)) - (while articles - (when (or (< (setq article (pop articles)) min) (> article max)) - (set var (delq article (symbol-value var))))))) + ;; Simultaneously uncompress and clip to active range + ;; See gnus-uncompress-range for a description of possible marks + (let (l lh) + (if (not (cadr marks)) + (set var nil) + (setq articles (if (numberp (cddr marks)) + (list (cdr marks)) + (cdr marks)) + lh (cons nil nil) + l lh) + + (while (setq article (pop articles)) + (cond ((consp article) + (setq bgn (max (car article) min) + end (min (cdr article) max)) + (while (<= bgn end) + (setq l (setcdr l (cons bgn nil)) + bgn (1+ bgn)))) + ((and (<= min article) + (>= max article)) + (setq l (setcdr l (cons article nil)))))) + (set var (cdr lh))))) ;; Adjust assocs. ((eq mark-type 'tuple) (set var (setq articles (cdr marks))) @@ -6358,15 +6373,15 @@ displayed, no centering will be performed." (while read (when first (while (< first nlast) - (push first unread) - (setq first (1+ first)))) + (setq unread (cons first unread) + first (1+ first)))) (setq first (1+ (if (atom (car read)) (car read) (cdar read)))) (setq nlast (if (atom (cadr read)) (cadr read) (caadr read))) (setq read (cdr read))))) ;; And add the last unread articles. (while (<= first last) - (push first unread) - (setq first (1+ first))) + (setq unread (cons first unread) + first (1+ first))) ;; Return the list of unread articles. (delq 0 (nreverse unread)))) @@ -6384,6 +6399,44 @@ displayed, no centering will be performed." (cdr (assq 'dormant marked))) (cdr (assq 'tick marked)))))) +;; This function returns a sequence of article numbers based on the +;; difference between the ranges of read articles in this group and +;; the range of active articles. +(defun gnus-sequence-of-unread-articles (group) + (let* ((read (gnus-info-read (gnus-get-info group))) + (active (or (gnus-active group) (gnus-activate-group group))) + (last (cdr active)) + first nlast unread) + ;; If none are read, then all are unread. + (if (not read) + (setq first (car active)) + ;; If the range of read articles is a single range, then the + ;; first unread article is the article after the last read + ;; article. Sounds logical, doesn't it? + (if (and (not (listp (cdr read))) + (or (< (car read) (car active)) + (progn (setq read (list read)) + nil))) + (setq first (max (car active) (1+ (cdr read)))) + ;; `read' is a list of ranges. + (when (/= (setq nlast (or (and (numberp (car read)) (car read)) + (caar read))) + 1) + (setq first (car active))) + (while read + (when first + (push (cons first nlast) unread)) + (setq first (1+ (if (atom (car read)) (car read) (cdar read)))) + (setq nlast (if (atom (cadr read)) (cadr read) (caadr read))) + (setq read (cdr read))))) + ;; And add the last unread articles. + (cond ((< first last) + (push (cons first last) unread)) + ((= first last) + (push first unread))) + ;; Return the sequence of unread articles. + (delq 0 (nreverse unread)))) + ;; Various summary commands (defun gnus-summary-select-article-buffer () @@ -11310,7 +11363,8 @@ If REVERSE, save parts that do not match TYPE." (default-high gnus-summary-default-high-score) (default-low gnus-summary-default-low-score) (uncached (and gnus-summary-use-undownloaded-faces - (memq article gnus-newsgroup-undownloaded)))) + (memq article gnus-newsgroup-undownloaded) + (not (memq article gnus-newsgroup-cached))))) (let ((face (funcall (gnus-summary-highlight-line-0)))) (unless (eq face (get-text-property beg 'face)) (gnus-put-text-property-excluding-characters-with-faces diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index 22db7ecd6d1..4b71e252f6e 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -38,7 +38,11 @@ (eval-when-compile (require 'cl) ;; Fixme: this should be a gnus variable, not nnmail-. - (defvar nnmail-pathname-coding-system)) + (defvar nnmail-pathname-coding-system) + + ;; Inappropriate references to other parts of Gnus. + (defvar gnus-emphasize-whitespace-regexp) + ) (require 'time-date) (require 'netrc) @@ -1186,7 +1190,7 @@ is run." "Delete by side effect any elements of LIST whose car is `equal' to KEY. The modified LIST is returned. If the first member of LIST has a car that is `equal' to KEY, there is no way to remove it -by side effect; therefore, write `(setq foo (remassoc key foo))' to be +by side effect; therefore, write `(setq foo (gnus-remassoc key foo))' to be sure of changing the value of `foo'." (when alist (if (equal key (caar alist)) @@ -1512,6 +1516,28 @@ predicate on the elements." ""))) (t emacs-version)))) +(defun gnus-rename-file (old-path new-path &optional trim) + "Rename OLD-PATH as NEW-PATH. If TRIM, recursively delete +empty directories from OLD-PATH." + (when (file-exists-p old-path) + (let* ((old-dir (file-name-directory old-path)) + (old-name (file-name-nondirectory old-path)) + (new-dir (file-name-directory new-path)) + (new-name (file-name-nondirectory new-path)) + temp) + (gnus-make-directory new-dir) + (rename-file old-path new-path t) + (when trim + (while (progn (setq temp (directory-files old-dir)) + (while (member (car temp) '("." "..")) + (setq temp (cdr temp))) + (= (length temp) 0)) + (delete-directory old-dir) + (setq old-dir (file-name-as-directory + (file-truename + (concat old-dir ".."))))))))) + + (provide 'gnus-util) ;;; arch-tag: f94991af-d32b-4c97-8c26-ca12a934de49 diff --git a/lisp/gnus/mm-view.el b/lisp/gnus/mm-view.el index c0ed098fa6f..9c22298c678 100644 --- a/lisp/gnus/mm-view.el +++ b/lisp/gnus/mm-view.el @@ -199,13 +199,14 @@ (setq w3m-display-inline-images mm-inline-text-html-with-images)) (defun mm-w3m-cid-retrieve-1 (url handle) - (if (mm-multiple-handles handle) - (dolist (elem handle) - (mm-w3m-cid-retrieve-1 url elem)) - (when (and (listp handle) - (equal url (mm-handle-id handle))) - (mm-insert-part handle) - (throw 'found-handle (mm-handle-media-type handle))))) + (dolist (elem handle) + (when (listp elem) + (if (equal url (mm-handle-id elem)) + (progn + (mm-insert-part elem) + (throw 'found-handle (mm-handle-media-type elem)))) + (if (equal "multipart" (mm-handle-media-supertype elem)) + (mm-w3m-cid-retrieve-1 url elem))))) (defun mm-w3m-cid-retrieve (url &rest args) "Insert a content pointed by URL if it has the cid: scheme." diff --git a/lisp/gnus/nnagent.el b/lisp/gnus/nnagent.el index 669aa6904dd..a17e92ce001 100644 --- a/lisp/gnus/nnagent.el +++ b/lisp/gnus/nnagent.el @@ -103,7 +103,7 @@ (defun nnagent-request-type (group article) (unless (stringp article) - (let ((gnus-plugged t)) + (let ((gnus-agent nil)) (if (not (gnus-check-backend-function 'request-type (car gnus-command-method))) 'unknown @@ -122,9 +122,14 @@ (deffoo nnagent-request-set-mark (group action server) (with-temp-buffer - (insert (format "(%s-request-set-mark \"%s\" '%s \"%s\")\n" - (nth 0 gnus-command-method) group action - (or server (nth 1 gnus-command-method)))) + (insert "(gnus-agent-synchronize-group-flags \"" + group + "\" '") + (gnus-pp action) + (insert " \"" + (gnus-method-to-server gnus-command-method) + "\"") + (insert ")\n") (append-to-file (point-min) (point-max) (gnus-agent-lib-file "flags"))) nil) |