Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-srvr.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 1917ad0d78d7
children d620409f5eb8
comparison
equal deleted inserted replaced
29:7976500f47f9 30:ec9a17fef872
53 `((?h how ?s) 53 `((?h how ?s)
54 (?n name ?s) 54 (?n name ?s)
55 (?w where ?s) 55 (?w where ?s)
56 (?s status ?s))) 56 (?s status ?s)))
57 57
58 (defvar gnus-server-mode-line-format-alist 58 (defvar gnus-server-mode-line-format-alist
59 `((?S news-server ?s) 59 `((?S news-server ?s)
60 (?M news-method ?s) 60 (?M news-method ?s)
61 (?u user-defined ?s))) 61 (?u user-defined ?s)))
62 62
63 (defvar gnus-server-line-format-spec nil) 63 (defvar gnus-server-line-format-spec nil)
135 (defun gnus-server-mode () 135 (defun gnus-server-mode ()
136 "Major mode for listing and editing servers. 136 "Major mode for listing and editing servers.
137 137
138 All normal editing commands are switched off. 138 All normal editing commands are switched off.
139 \\<gnus-server-mode-map> 139 \\<gnus-server-mode-map>
140 For more in-depth information on this mode, read the manual 140 For more in-depth information on this mode, read the manual
141 (`\\[gnus-info-find-node]'). 141 (`\\[gnus-info-find-node]').
142 142
143 The following commands are available: 143 The following commands are available:
144 144
145 \\{gnus-server-mode-map}" 145 \\{gnus-server-mode-map}"
146 (interactive) 146 (interactive)
187 "Initialize the server buffer." 187 "Initialize the server buffer."
188 (unless (get-buffer gnus-server-buffer) 188 (unless (get-buffer gnus-server-buffer)
189 (save-excursion 189 (save-excursion
190 (set-buffer (get-buffer-create gnus-server-buffer)) 190 (set-buffer (get-buffer-create gnus-server-buffer))
191 (gnus-server-mode) 191 (gnus-server-mode)
192 (when gnus-carpal 192 (when gnus-carpal
193 (gnus-carpal-setup-buffer 'server))))) 193 (gnus-carpal-setup-buffer 'server)))))
194 194
195 (defun gnus-server-prepare () 195 (defun gnus-server-prepare ()
196 (setq gnus-server-mode-line-format-spec 196 (setq gnus-server-mode-line-format-spec
197 (gnus-parse-format gnus-server-mode-line-format 197 (gnus-parse-format gnus-server-mode-line-format
198 gnus-server-mode-line-format-alist)) 198 gnus-server-mode-line-format-alist))
199 (setq gnus-server-line-format-spec 199 (setq gnus-server-line-format-spec
200 (gnus-parse-format gnus-server-line-format 200 (gnus-parse-format gnus-server-line-format
201 gnus-server-line-format-alist t)) 201 gnus-server-line-format-alist t))
202 (let ((alist gnus-server-alist) 202 (let ((alist gnus-server-alist)
203 (buffer-read-only nil) 203 (buffer-read-only nil)
204 (opened gnus-opened-servers) 204 (opened gnus-opened-servers)
205 done server op-ser) 205 done server op-ser)
207 (setq gnus-inserted-opened-servers nil) 207 (setq gnus-inserted-opened-servers nil)
208 ;; First we do the real list of servers. 208 ;; First we do the real list of servers.
209 (while alist 209 (while alist
210 (unless (member (cdar alist) done) 210 (unless (member (cdar alist) done)
211 (push (cdar alist) done) 211 (push (cdar alist) done)
212 (cdr (setq server (pop alist))) 212 (cdr (setq server (pop alist)))
213 (when (and server (car server) (cdr server)) 213 (when (and server (car server) (cdr server))
214 (gnus-server-insert-server-line (car server) (cdr server))))) 214 (gnus-server-insert-server-line (car server) (cdr server)))))
215 ;; Then we insert the list of servers that have been opened in 215 ;; Then we insert the list of servers that have been opened in
216 ;; this session. 216 ;; this session.
217 (while opened 217 (while opened
218 (unless (member (caar opened) done) 218 (unless (member (caar opened) done)
219 (push (caar opened) done) 219 (push (caar opened) done)
220 (gnus-server-insert-server-line 220 (gnus-server-insert-server-line
221 (setq op-ser (format "%s:%s" (caaar opened) (nth 1 (caar opened)))) 221 (setq op-ser (format "%s:%s" (caaar opened) (nth 1 (caar opened))))
222 (caar opened)) 222 (caar opened))
223 (push (list op-ser (caar opened)) gnus-inserted-opened-servers)) 223 (push (list op-ser (caar opened)) gnus-inserted-opened-servers))
224 (setq opened (cdr opened)))) 224 (setq opened (cdr opened))))
225 (goto-char (point-min)) 225 (goto-char (point-min))
239 (let* ((buffer-read-only nil) 239 (let* ((buffer-read-only nil)
240 (entry (assoc server gnus-server-alist)) 240 (entry (assoc server gnus-server-alist))
241 (oentry (assoc (gnus-server-to-method server) 241 (oentry (assoc (gnus-server-to-method server)
242 gnus-opened-servers))) 242 gnus-opened-servers)))
243 (when entry 243 (when entry
244 (gnus-dribble-enter 244 (gnus-dribble-enter
245 (concat "(gnus-server-set-info \"" server "\" '" 245 (concat "(gnus-server-set-info \"" server "\" '"
246 (prin1-to-string (cdr entry)) ")\n"))) 246 (prin1-to-string (cdr entry)) ")\n")))
247 (when (or entry oentry) 247 (when (or entry oentry)
248 ;; Buffer may be narrowed. 248 ;; Buffer may be narrowed.
249 (save-restriction 249 (save-restriction
250 (widen) 250 (widen)
251 (when (gnus-server-goto-server server) 251 (when (gnus-server-goto-server server)
252 (gnus-delete-line)) 252 (gnus-delete-line))
253 (if entry 253 (if entry
254 (gnus-server-insert-server-line (car entry) (cdr entry)) 254 (gnus-server-insert-server-line (car entry) (cdr entry))
255 (gnus-server-insert-server-line 255 (gnus-server-insert-server-line
256 (format "%s:%s" (caar oentry) (nth 1 (car oentry))) 256 (format "%s:%s" (caar oentry) (nth 1 (car oentry)))
257 (car oentry))) 257 (car oentry)))
258 (gnus-server-position-point)))))) 258 (gnus-server-position-point))))))
259 259
260 (defun gnus-server-set-info (server info) 260 (defun gnus-server-set-info (server info)
261 ;; Enter a select method into the virtual server alist. 261 ;; Enter a select method into the virtual server alist.
262 (when (and server info) 262 (when (and server info)
263 (gnus-dribble-enter 263 (gnus-dribble-enter
264 (concat "(gnus-server-set-info \"" server "\" '" 264 (concat "(gnus-server-set-info \"" server "\" '"
265 (prin1-to-string info) ")")) 265 (prin1-to-string info) ")"))
266 (let* ((server (nth 1 info)) 266 (let* ((server (nth 1 info))
267 (entry (assoc server gnus-server-alist))) 267 (entry (assoc server gnus-server-alist)))
268 (if entry (setcdr entry info) 268 (if entry (setcdr entry info)
418 (setcar (nthcdr 2 to-entry) to) 418 (setcar (nthcdr 2 to-entry) to)
419 (push to-entry gnus-server-killed-servers) 419 (push to-entry gnus-server-killed-servers)
420 (gnus-server-yank-server))) 420 (gnus-server-yank-server)))
421 421
422 (defun gnus-server-add-server (how where) 422 (defun gnus-server-add-server (how where)
423 (interactive 423 (interactive
424 (list (intern (completing-read "Server method: " 424 (list (intern (completing-read "Server method: "
425 gnus-valid-select-methods nil t)) 425 gnus-valid-select-methods nil t))
426 (read-string "Server name: "))) 426 (read-string "Server name: ")))
427 (when (assq where gnus-server-alist) 427 (when (assq where gnus-server-alist)
428 (error "Server with that name already defined")) 428 (error "Server with that name already defined"))
470 (gnus-browse-foreign-server (gnus-server-to-method server) buf) 470 (gnus-browse-foreign-server (gnus-server-to-method server) buf)
471 (save-excursion 471 (save-excursion
472 (set-buffer buf) 472 (set-buffer buf)
473 (gnus-server-update-server (gnus-server-server-name)) 473 (gnus-server-update-server (gnus-server-server-name))
474 (gnus-server-position-point))))) 474 (gnus-server-position-point)))))
475 475
476 (defun gnus-server-pick-server (e) 476 (defun gnus-server-pick-server (e)
477 (interactive "e") 477 (interactive "e")
478 (mouse-set-point e) 478 (mouse-set-point e)
479 (gnus-server-read-server (gnus-server-server-name))) 479 (gnus-server-read-server (gnus-server-server-name)))
480 480
729 729
730 (defun gnus-server-regenerate-server () 730 (defun gnus-server-regenerate-server ()
731 "Issue a command to the server to regenerate all its data structures." 731 "Issue a command to the server to regenerate all its data structures."
732 (interactive) 732 (interactive)
733 (let ((server (gnus-server-server-name))) 733 (let ((server (gnus-server-server-name)))
734 (unless server 734 (unless server
735 (error "No server on the current line")) 735 (error "No server on the current line"))
736 (if (not (gnus-check-backend-function 736 (if (not (gnus-check-backend-function
737 'request-regenerate (car (gnus-server-to-method server)))) 737 'request-regenerate (car (gnus-server-to-method server))))
738 (error "This backend doesn't support regeneration") 738 (error "This backend doesn't support regeneration")
739 (gnus-message 5 "Requesting regeneration of %s..." server) 739 (gnus-message 5 "Requesting regeneration of %s..." server)
740 (if (gnus-request-regenerate server) 740 (if (gnus-request-regenerate server)
741 (gnus-message 5 "Requesting regeneration of %s...done" server) 741 (gnus-message 5 "Requesting regeneration of %s...done" server)
742 (gnus-message 5 "Couldn't regenerate %s" server))))) 742 (gnus-message 5 "Couldn't regenerate %s" server)))))
743 743
744 (provide 'gnus-srvr) 744 (provide 'gnus-srvr)
745 745
746 ;;; gnus-srvr.el ends here. 746 ;;; gnus-srvr.el ends here.