X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-srvr.el;h=8e3c6aaca3c0fa752b2166469cd8fc8c69ae24f1;hb=5b43013c733e2f34e11d594be848aad359e5c6ad;hp=5a2f895785fb4601d00fbee89788f75026fb136c;hpb=19129ec856209505e3ba9f85d67736d6ac974e6d;p=gnus diff --git a/lisp/gnus-srvr.el b/lisp/gnus-srvr.el index 5a2f89578..8e3c6aaca 100644 --- a/lisp/gnus-srvr.el +++ b/lisp/gnus-srvr.el @@ -1,17 +1,17 @@ ;;; gnus-srvr.el --- virtual server support for Gnus ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, -;; 2004, 2005 Free Software Foundation, Inc. +;; 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -19,9 +19,7 @@ ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -179,6 +177,7 @@ If nil, a faster, but more primitive, buffer is used instead." :group 'gnus-server-visual) ;; backward-compatibility alias (put 'gnus-server-agent-face 'face-alias 'gnus-server-agent) +(put 'gnus-server-agent-face 'obsolete-face "22.1") (defface gnus-server-opened '((((class color) (background light)) (:foreground "Green3" :bold t)) @@ -188,16 +187,18 @@ If nil, a faster, but more primitive, buffer is used instead." :group 'gnus-server-visual) ;; backward-compatibility alias (put 'gnus-server-opened-face 'face-alias 'gnus-server-opened) +(put 'gnus-server-opened-face 'obsolete-face "22.1") (defface gnus-server-closed '((((class color) (background light)) (:foreground "Steel Blue" :italic t)) (((class color) (background dark)) - (:foreground "Light Steel Blue" :italic t)) + (:foreground "LightBlue" :italic t)) (t (:italic t))) "Face used for displaying CLOSED servers" :group 'gnus-server-visual) ;; backward-compatibility alias (put 'gnus-server-closed-face 'face-alias 'gnus-server-closed) +(put 'gnus-server-closed-face 'obsolete-face "22.1") (defface gnus-server-denied '((((class color) (background light)) (:foreground "Red" :bold t)) @@ -207,6 +208,7 @@ If nil, a faster, but more primitive, buffer is used instead." :group 'gnus-server-visual) ;; backward-compatibility alias (put 'gnus-server-denied-face 'face-alias 'gnus-server-denied) +(put 'gnus-server-denied-face 'obsolete-face "22.1") (defface gnus-server-offline '((((class color) (background light)) (:foreground "Orange" :bold t)) @@ -216,44 +218,14 @@ If nil, a faster, but more primitive, buffer is used instead." :group 'gnus-server-visual) ;; backward-compatibility alias (put 'gnus-server-offline-face 'face-alias 'gnus-server-offline) - -(defcustom gnus-server-agent-face 'gnus-server-agent - "Face name to use on AGENTIZED servers." - :version "22.1" - :group 'gnus-server-visual - :type 'face) - -(defcustom gnus-server-opened-face 'gnus-server-opened - "Face name to use on OPENED servers." - :version "22.1" - :group 'gnus-server-visual - :type 'face) - -(defcustom gnus-server-closed-face 'gnus-server-closed - "Face name to use on CLOSED servers." - :version "22.1" - :group 'gnus-server-visual - :type 'face) - -(defcustom gnus-server-denied-face 'gnus-server-denied - "Face name to use on DENIED servers." - :version "22.1" - :group 'gnus-server-visual - :type 'face) - -(defcustom gnus-server-offline-face 'gnus-server-offline - "Face name to use on OFFLINE servers." - :version "22.1" - :group 'gnus-server-visual - :type 'face) +(put 'gnus-server-offline-face 'obsolete-face "22.1") (defvar gnus-server-font-lock-keywords - (list - '("(\\(agent\\))" 1 gnus-server-agent-face) - '("(\\(opened\\))" 1 gnus-server-opened-face) - '("(\\(closed\\))" 1 gnus-server-closed-face) - '("(\\(offline\\))" 1 gnus-server-offline-face) - '("(\\(denied\\))" 1 gnus-server-denied-face))) + '(("(\\(agent\\))" 1 'gnus-server-agent) + ("(\\(opened\\))" 1 'gnus-server-opened) + ("(\\(closed\\))" 1 'gnus-server-closed) + ("(\\(offline\\))" 1 'gnus-server-offline) + ("(\\(denied\\))" 1 'gnus-server-denied))) (defun gnus-server-mode () "Major mode for listing and editing servers. @@ -311,19 +283,23 @@ The following commands are available: ;; Insert the text. (eval gnus-server-line-format-spec)) (list 'gnus-server (intern gnus-tmp-name) - 'gnus-named-server (intern (gnus-method-to-server method)))))) + 'gnus-named-server (intern (gnus-method-to-server method t)))))) (defun gnus-enter-server-buffer () "Set up the server buffer." (gnus-server-setup-buffer) (gnus-configure-windows 'server) - (gnus-server-prepare)) + ;; Usually `gnus-configure-windows' will finish with the + ;; `gnus-server-buffer' selected as the current buffer, but not always (I + ;; bumped into it when starting from a dedicated *Group* frame, and + ;; gnus-configure-windows opened *Server* into its own dedicated frame). + (with-current-buffer (get-buffer gnus-server-buffer) + (gnus-server-prepare))) (defun gnus-server-setup-buffer () "Initialize the server buffer." (unless (get-buffer gnus-server-buffer) - (save-excursion - (set-buffer (gnus-get-buffer-create gnus-server-buffer)) + (with-current-buffer (gnus-get-buffer-create gnus-server-buffer) (gnus-server-mode) (when gnus-carpal (gnus-carpal-setup-buffer 'server))))) @@ -374,8 +350,7 @@ The following commands are available: (defconst gnus-server-edit-buffer "*Gnus edit server*") (defun gnus-server-update-server (server) - (save-excursion - (set-buffer gnus-server-buffer) + (with-current-buffer gnus-server-buffer (let* ((buffer-read-only nil) (entry (assoc server gnus-server-alist)) (oentry (assoc (gnus-server-to-method server) @@ -548,6 +523,8 @@ The following commands are available: "Close all servers." (interactive) (dolist (server gnus-inserted-opened-servers) + (gnus-server-close-server (car server))) + (dolist (server gnus-server-alist) (gnus-server-close-server (car server)))) (defun gnus-server-deny-server (server) @@ -624,7 +601,8 @@ The following commands are available: `(lambda (form) (gnus-server-set-info ,server form) (gnus-server-list-servers) - (gnus-server-position-point))))) + (gnus-server-position-point)) + 'edit-server))) (defun gnus-server-scan-server (server) "Request a scan from the current server." @@ -648,8 +626,7 @@ The following commands are available: (let ((buf (current-buffer))) (prog1 (gnus-browse-foreign-server server buf) - (save-excursion - (set-buffer buf) + (with-current-buffer buf (gnus-server-update-server (gnus-server-server-name)) (gnus-server-position-point))))) @@ -755,11 +732,12 @@ The following commands are available: (while (not (eobp)) (ignore-errors (push (cons - (buffer-substring - (point) - (progn - (skip-chars-forward "^ \t") - (point))) + (mm-string-as-unibyte + (buffer-substring + (point) + (progn + (skip-chars-forward "^ \t") + (point)))) (let ((last (read cur))) (cons (read cur) last))) groups)) @@ -767,18 +745,19 @@ The following commands are available: (while (not (eobp)) (ignore-errors (push (cons - (if (eq (char-after) ?\") - (read cur) - (let ((p (point)) (name "")) - (skip-chars-forward "^ \t\\\\") - (setq name (buffer-substring p (point))) - (while (eq (char-after) ?\\) - (setq p (1+ (point))) - (forward-char 2) - (skip-chars-forward "^ \t\\\\") - (setq name (concat name (buffer-substring - p (point))))) - name)) + (mm-string-as-unibyte + (if (eq (char-after) ?\") + (read cur) + (let ((p (point)) (name "")) + (skip-chars-forward "^ \t\\\\") + (setq name (buffer-substring p (point))) + (while (eq (char-after) ?\\) + (setq p (1+ (point))) + (forward-char 2) + (skip-chars-forward "^ \t\\\\") + (setq name (concat name (buffer-substring + p (point))))) + name))) (let ((last (read cur))) (cons (read cur) last))) groups)) @@ -958,18 +937,22 @@ If NUMBER, fetch this number of articles." (progn ;; Make sure the group has been properly removed before we ;; subscribe to it. - (gnus-kill-ephemeral-group group) + (if (gnus-ephemeral-group-p group) + (gnus-kill-ephemeral-group group)) + ;; We need to discern between killed/zombie groups and + ;; just unsubscribed ones. (gnus-group-change-level - (list t group gnus-level-default-subscribed - nil nil (if (gnus-server-equal - gnus-browse-current-method "native") - nil - (gnus-method-simplify - gnus-browse-current-method))) + (or (gnus-group-entry group) + (list t group gnus-level-default-subscribed + nil nil (if (gnus-server-equal + gnus-browse-current-method "native") + nil + (gnus-method-simplify + gnus-browse-current-method)))) gnus-level-default-subscribed (gnus-group-level group) (and (car (nth 1 gnus-newsrc-alist)) (gnus-group-entry (car (nth 1 gnus-newsrc-alist)))) - t) + (null (gnus-group-entry group))) (delete-char 1) (insert ? )) (gnus-group-change-level @@ -984,8 +967,7 @@ If NUMBER, fetch this number of articles." (when (eq major-mode 'gnus-browse-mode) (gnus-kill-buffer (current-buffer))) ;; Insert the newly subscribed groups in the group buffer. - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (gnus-group-list-groups nil)) (if gnus-browse-return-buffer (gnus-configure-windows 'server 'force) @@ -1051,5 +1033,5 @@ Requesting compaction of %s... (this may take a long time)" (provide 'gnus-srvr) -;;; arch-tag: c0117f64-27ca-475d-9406-8da6854c7a25 +;; arch-tag: c0117f64-27ca-475d-9406-8da6854c7a25 ;;; gnus-srvr.el ends here