X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-move.el;h=26f83050fd6efd3b53bbefeafc3908132875f206;hp=dd39935a2045a63eaafb8242e91919c5a370b7ab;hb=21fd4405906dd1efdcdbdf0d5bf9195aea4602f8;hpb=7c13cb18da8d917ec6688dd63face28caf457158 diff --git a/lisp/gnus-move.el b/lisp/gnus-move.el index dd39935a2..26f83050f 100644 --- a/lisp/gnus-move.el +++ b/lisp/gnus-move.el @@ -1,7 +1,8 @@ ;;; gnus-move.el --- commands for moving Gnus from one server to another -;; Copyright (C) 1996 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1998, 1999, 2000 +;; Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen +;; Author: Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. @@ -25,6 +26,8 @@ ;;; Code: +(eval-when-compile (require 'cl)) + (require 'gnus) (require 'gnus-start) (require 'gnus-int) @@ -40,18 +43,17 @@ Update the .newsrc.eld file to reflect the change of nntp server." (interactive (list gnus-select-method (gnus-read-method "Move to method: "))) - + ;; First start Gnus. (let ((gnus-activate-level 0) + (mail-sources nil) (nnmail-spool-file nil)) (gnus)) (save-excursion ;; Go through all groups and translate. - (let ((newsrc gnus-newsrc-alist) - (nntp-nov-gap nil) - info) - (while (setq info (pop newsrc)) + (let ((nntp-nov-gap nil)) + (dolist (info gnus-newsrc-alist) (when (gnus-group-native-p (gnus-info-group info)) (gnus-move-group-to-server info from-server to-server)))))) @@ -59,14 +61,19 @@ Update the .newsrc.eld file to reflect the change of nntp server." "Move group INFO from FROM-SERVER to TO-SERVER." (let ((group (gnus-info-group info)) to-active hashtb type mark marks - to-article to-reads to-marks article) + to-article to-reads to-marks article + act-articles) (gnus-message 7 "Translating %s..." group) (when (gnus-request-group group nil to-server) (setq to-active (gnus-parse-active) - hashtb (make-vector 1023 0)) + hashtb (gnus-make-hashtable 1024) + act-articles (gnus-uncompress-range to-active)) ;; Fetch the headers from the `to-server'. - (when (setq type (gnus-retrieve-headers - (gnus-uncompress-range to-active) group to-server)) + (when (and to-active + act-articles + (setq type (gnus-retrieve-headers + act-articles + group to-server))) ;; Convert HEAD headers. I don't care. (when (eq type 'headers) (nnvirtual-convert-headers)) @@ -74,9 +81,8 @@ Update the .newsrc.eld file to reflect the change of nntp server." (set-buffer nntp-server-buffer) (goto-char (point-min)) (while (looking-at - "^[0-9]+\t[^\t]*\t[^\t]*\t[^\t]*\t\\([^\t]*\\)\t" - nil t) - (gnus-sethash + "^[0-9]+\t[^\t]*\t[^\t]*\t[^\t]*\t\\([^\t]*\\)\t") + (gnus-sethash (buffer-substring (match-beginning 1) (match-end 1)) (read (current-buffer)) hashtb) @@ -84,8 +90,10 @@ Update the .newsrc.eld file to reflect the change of nntp server." ;; Then we read the headers from the `from-server'. (when (and (gnus-request-group group nil from-server) (gnus-active group) + (gnus-uncompress-range + (gnus-active group)) (setq type (gnus-retrieve-headers - (gnus-uncompress-range + (gnus-uncompress-range (gnus-active group)) group from-server))) ;; Make it easier to map marks. @@ -106,26 +114,28 @@ Update the .newsrc.eld file to reflect the change of nntp server." (set-buffer nntp-server-buffer) (goto-char (point-min)) (while (looking-at - "^[0-9]+\t[^\t]*\t[^\t]*\t[^\t]*\t\\([^\t]*\\)\t" - nil t) - (setq to-article - (gnus-gethash - (buffer-substring (match-beginning 1) (match-end 1)) - hashtb)) - ;; Add this article to the list of read articles. - (push to-article to-reads) - ;; See if there are any marks and then add them. - (when (setq mark (assq (read (current-buffer)) marks)) - (setq marks (delq mark marks)) - (setcar mark to-article) - (push mark to-marks)) - (forward-line 1)) + "^[0-9]+\t[^\t]*\t[^\t]*\t[^\t]*\t\\([^\t]*\\)\t") + (when (setq to-article + (gnus-gethash + (buffer-substring (match-beginning 1) (match-end 1)) + hashtb)) + ;; Add this article to the list of read articles. + (push to-article to-reads) + ;; See if there are any marks and then add them. + (when (setq mark (assq (read (current-buffer)) marks)) + (setq marks (delq mark marks)) + (setcar mark to-article) + (push mark to-marks)) + (forward-line 1))) ;; Now we know what the read articles are and what the ;; article marks are. We transform the information ;; into the Gnus info format. - (setq to-reads - (gnus-range-add - (gnus-compress-sequence (sort to-reads '<) t) + (setq to-reads + (gnus-range-add + (gnus-compress-sequence + (and (setq to-reads (delq nil to-reads)) + (sort to-reads '<)) + t) (cons 1 (1- (car to-active))))) (gnus-info-set-read info to-reads) ;; Do the marks. I'm sure y'all understand what's @@ -142,9 +152,10 @@ Update the .newsrc.eld file to reflect the change of nntp server." (cons article (cdr a))))) (setq a lists) (while a - (setcdr (car a) (gnus-compress-sequence (sort (cdar a) '<))) + (setcdr (car a) (gnus-compress-sequence + (and (cdar a) (sort (cdar a) '<)))) (pop a)) - (gnus-info-set-marks info lists))))) + (gnus-info-set-marks info lists t))))) (gnus-message 7 "Translating %s...done" group))) (defun gnus-group-move-group-to-server (info from-server to-server) @@ -152,7 +163,7 @@ Update the .newsrc.eld file to reflect the change of nntp server." (interactive (let ((info (gnus-get-info (gnus-group-group-name)))) (list info (gnus-find-method-for-group (gnus-info-group info)) - (gnus-read-method (format "Move group %s to method: " + (gnus-read-method (format "Move group %s to method: " (gnus-info-group info)))))) (save-excursion (gnus-move-group-to-server info from-server to-server) @@ -160,13 +171,13 @@ Update the .newsrc.eld file to reflect the change of nntp server." (gnus-info-set-method info to-server t) ;; We also have to change the name of the group and stuff. (let* ((group (gnus-info-group info)) - (new-name (gnus-group-prefixed-name + (new-name (gnus-group-prefixed-name (gnus-group-real-name group) to-server))) (gnus-info-set-group info new-name) - (gnus-sethash new-name (gnus-gethash group gnus-newsrc-hashtb) - gnus-newsrc-hashtb) + (gnus-sethash new-name (gnus-group-entry group) gnus-newsrc-hashtb) (gnus-sethash group nil gnus-newsrc-hashtb)))) (provide 'gnus-move) +;;; arch-tag: 503742b8-7d66-4d79-bb31-4a698070707b ;;; gnus-move.el ends here