Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-move.el @ 30:ec9a17fef872 r19-15b98

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b98
author cvs
date Mon, 13 Aug 2007 08:52:29 +0200
parents 0293115a14e9
children 43dd3413c7c7
comparison
equal deleted inserted replaced
29:7976500f47f9 30:ec9a17fef872
38 (defun gnus-change-server (from-server to-server) 38 (defun gnus-change-server (from-server to-server)
39 "Move from FROM-SERVER to TO-SERVER. 39 "Move from FROM-SERVER to TO-SERVER.
40 Update the .newsrc.eld file to reflect the change of nntp server." 40 Update the .newsrc.eld file to reflect the change of nntp server."
41 (interactive 41 (interactive
42 (list gnus-select-method (gnus-read-method "Move to method: "))) 42 (list gnus-select-method (gnus-read-method "Move to method: ")))
43 43
44 ;; First start Gnus. 44 ;; First start Gnus.
45 (let ((gnus-activate-level 0) 45 (let ((gnus-activate-level 0)
46 (nnmail-spool-file nil)) 46 (nnmail-spool-file nil))
47 (gnus)) 47 (gnus))
48 48
75 ;; Create a mapping from Message-ID to article number. 75 ;; Create a mapping from Message-ID to article number.
76 (set-buffer nntp-server-buffer) 76 (set-buffer nntp-server-buffer)
77 (goto-char (point-min)) 77 (goto-char (point-min))
78 (while (looking-at 78 (while (looking-at
79 "^[0-9]+\t[^\t]*\t[^\t]*\t[^\t]*\t\\([^\t]*\\)\t") 79 "^[0-9]+\t[^\t]*\t[^\t]*\t[^\t]*\t\\([^\t]*\\)\t")
80 (gnus-sethash 80 (gnus-sethash
81 (buffer-substring (match-beginning 1) (match-end 1)) 81 (buffer-substring (match-beginning 1) (match-end 1))
82 (read (current-buffer)) 82 (read (current-buffer))
83 hashtb) 83 hashtb)
84 (forward-line 1)) 84 (forward-line 1))
85 ;; Then we read the headers from the `from-server'. 85 ;; Then we read the headers from the `from-server'.
86 (when (and (gnus-request-group group nil from-server) 86 (when (and (gnus-request-group group nil from-server)
87 (gnus-active group) 87 (gnus-active group)
88 (setq type (gnus-retrieve-headers 88 (setq type (gnus-retrieve-headers
89 (gnus-uncompress-range 89 (gnus-uncompress-range
90 (gnus-active group)) 90 (gnus-active group))
91 group from-server))) 91 group from-server)))
92 ;; Make it easier to map marks. 92 ;; Make it easier to map marks.
93 (let ((mark-lists (gnus-info-marks info)) 93 (let ((mark-lists (gnus-info-marks info))
94 ms type m) 94 ms type m)
106 ;; Go through the headers and map away. 106 ;; Go through the headers and map away.
107 (set-buffer nntp-server-buffer) 107 (set-buffer nntp-server-buffer)
108 (goto-char (point-min)) 108 (goto-char (point-min))
109 (while (looking-at 109 (while (looking-at
110 "^[0-9]+\t[^\t]*\t[^\t]*\t[^\t]*\t\\([^\t]*\\)\t") 110 "^[0-9]+\t[^\t]*\t[^\t]*\t[^\t]*\t\\([^\t]*\\)\t")
111 (setq to-article 111 (setq to-article
112 (gnus-gethash 112 (gnus-gethash
113 (buffer-substring (match-beginning 1) (match-end 1)) 113 (buffer-substring (match-beginning 1) (match-end 1))
114 hashtb)) 114 hashtb))
115 ;; Add this article to the list of read articles. 115 ;; Add this article to the list of read articles.
116 (push to-article to-reads) 116 (push to-article to-reads)
117 ;; See if there are any marks and then add them. 117 ;; See if there are any marks and then add them.
121 (push mark to-marks)) 121 (push mark to-marks))
122 (forward-line 1)) 122 (forward-line 1))
123 ;; Now we know what the read articles are and what the 123 ;; Now we know what the read articles are and what the
124 ;; article marks are. We transform the information 124 ;; article marks are. We transform the information
125 ;; into the Gnus info format. 125 ;; into the Gnus info format.
126 (setq to-reads 126 (setq to-reads
127 (gnus-range-add 127 (gnus-range-add
128 (gnus-compress-sequence (sort to-reads '<) t) 128 (gnus-compress-sequence (sort to-reads '<) t)
129 (cons 1 (1- (car to-active))))) 129 (cons 1 (1- (car to-active)))))
130 (gnus-info-set-read info to-reads) 130 (gnus-info-set-read info to-reads)
131 ;; Do the marks. I'm sure y'all understand what's 131 ;; Do the marks. I'm sure y'all understand what's
132 ;; going on down below, so I won't bother with any 132 ;; going on down below, so I won't bother with any
150 (defun gnus-group-move-group-to-server (info from-server to-server) 150 (defun gnus-group-move-group-to-server (info from-server to-server)
151 "Move the group on the current line from FROM-SERVER to TO-SERVER." 151 "Move the group on the current line from FROM-SERVER to TO-SERVER."
152 (interactive 152 (interactive
153 (let ((info (gnus-get-info (gnus-group-group-name)))) 153 (let ((info (gnus-get-info (gnus-group-group-name))))
154 (list info (gnus-find-method-for-group (gnus-info-group info)) 154 (list info (gnus-find-method-for-group (gnus-info-group info))
155 (gnus-read-method (format "Move group %s to method: " 155 (gnus-read-method (format "Move group %s to method: "
156 (gnus-info-group info)))))) 156 (gnus-info-group info))))))
157 (save-excursion 157 (save-excursion
158 (gnus-move-group-to-server info from-server to-server) 158 (gnus-move-group-to-server info from-server to-server)
159 ;; We have to update the group info to point use the right server. 159 ;; We have to update the group info to point use the right server.
160 (gnus-info-set-method info to-server t) 160 (gnus-info-set-method info to-server t)
161 ;; We also have to change the name of the group and stuff. 161 ;; We also have to change the name of the group and stuff.
162 (let* ((group (gnus-info-group info)) 162 (let* ((group (gnus-info-group info))
163 (new-name (gnus-group-prefixed-name 163 (new-name (gnus-group-prefixed-name
164 (gnus-group-real-name group) to-server))) 164 (gnus-group-real-name group) to-server)))
165 (gnus-info-set-group info new-name) 165 (gnus-info-set-group info new-name)
166 (gnus-sethash new-name (gnus-gethash group gnus-newsrc-hashtb) 166 (gnus-sethash new-name (gnus-gethash group gnus-newsrc-hashtb)
167 gnus-newsrc-hashtb) 167 gnus-newsrc-hashtb)
168 (gnus-sethash group nil gnus-newsrc-hashtb)))) 168 (gnus-sethash group nil gnus-newsrc-hashtb))))