X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-srvr.el;h=66509c939dc128bbbedb604bfb1c8a5676c373c8;hp=ffdfbf41ef618e21d15b07e4d0eeb10efc8d2a50;hb=bbe68edb313e02acb4557e5cc4ff2f87a41ca66c;hpb=596fb3c9b1f0036eb85df46d800eafa4840d64ef diff --git a/lisp/gnus-srvr.el b/lisp/gnus-srvr.el index ffdfbf41e..66509c939 100644 --- a/lisp/gnus-srvr.el +++ b/lisp/gnus-srvr.el @@ -1,17 +1,16 @@ ;;; gnus-srvr.el --- virtual server support for Gnus -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, -;; 2004, 2005, 2006, 2007 Free Software Foundation, Inc. +;; Copyright (C) 1995-2012 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 +18,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: @@ -30,11 +27,14 @@ (eval-when-compile (require 'cl)) (require 'gnus) +(require 'gnus-start) (require 'gnus-spec) (require 'gnus-group) (require 'gnus-int) (require 'gnus-range) +(autoload 'gnus-group-make-nnir-group "nnir") + (defcustom gnus-server-mode-hook nil "Hook run in `gnus-server-mode' buffers." :group 'gnus-server @@ -114,6 +114,7 @@ If nil, a faster, but more primitive, buffer is used instead." ["Kill" gnus-server-kill-server t] ["Yank" gnus-server-yank-server t] ["Copy" gnus-server-copy-server t] + ["Show" gnus-server-show-server t] ["Edit" gnus-server-edit-server t] ["Regenerate" gnus-server-regenerate-server t] ["Compact" gnus-server-compact-server t] @@ -151,6 +152,7 @@ If nil, a faster, but more primitive, buffer is used instead." "c" gnus-server-copy-server "a" gnus-server-add-server "e" gnus-server-edit-server + "S" gnus-server-show-server "s" gnus-server-scan-server "O" gnus-server-open-server @@ -166,6 +168,8 @@ If nil, a faster, but more primitive, buffer is used instead." "g" gnus-server-regenerate-server + "G" gnus-group-make-nnir-group + "z" gnus-server-compact-server "\C-c\C-i" gnus-info-find-node @@ -179,6 +183,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,6 +193,7 @@ 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)) @@ -198,6 +204,7 @@ If nil, a faster, but more primitive, buffer is used instead." :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 +214,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 +224,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,22 +289,24 @@ 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)) - (gnus-server-mode) - (when gnus-carpal - (gnus-carpal-setup-buffer 'server))))) + (with-current-buffer (gnus-get-buffer-create gnus-server-buffer) + (gnus-server-mode)))) (defun gnus-server-prepare () (gnus-set-format 'server-mode) @@ -350,7 +330,7 @@ The following commands are available: (dolist (open gnus-opened-servers) (when (and (not (member (car open) done)) ;; Just ignore ephemeral servers. - (not (member (car open) gnus-ephemeral-servers))) + (not (gnus-method-ephemeral-p (car open)))) (push (car open) done) (gnus-server-insert-server-line (setq op-ser (format "%s:%s" (caar open) (nth 1 (car open)))) @@ -374,8 +354,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) @@ -383,7 +362,8 @@ The following commands are available: (when entry (gnus-dribble-enter (concat "(gnus-server-set-info \"" server "\" '" - (gnus-prin1-to-string (cdr entry)) ")\n"))) + (gnus-prin1-to-string (cdr entry)) ")\n") + (concat "^(gnus-server-set-info \"" (regexp-quote server) "\""))) (when (or entry oentry) ;; Buffer may be narrowed. (save-restriction @@ -402,7 +382,8 @@ The following commands are available: (when (and server info) (gnus-dribble-enter (concat "(gnus-server-set-info \"" server "\" '" - (gnus-prin1-to-string info) ")")) + (gnus-prin1-to-string info) ")") + (concat "^(gnus-server-set-info \"" (regexp-quote server) "\"")) (let* ((server (nth 1 info)) (entry (assoc server gnus-server-alist)) (cached (assoc server gnus-server-method-cache))) @@ -548,6 +529,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) @@ -570,6 +553,7 @@ The following commands are available: (gnus-server-list-servers)) (defun gnus-server-copy-server (from to) + "Copy a server definition to a new name." (interactive (list (or (gnus-server-server-name) @@ -592,8 +576,9 @@ The following commands are available: (defun gnus-server-add-server (how where) (interactive - (list (intern (completing-read "Server method: " - gnus-valid-select-methods nil t)) + (list (intern (gnus-completing-read "Server method" + (mapcar 'car gnus-valid-select-methods) + t)) (read-string "Server name: "))) (when (assq where gnus-server-alist) (error "Server with that name already defined")) @@ -603,7 +588,7 @@ The following commands are available: (defun gnus-server-goto-server (server) "Jump to a server line." (interactive - (list (completing-read "Goto server: " gnus-server-alist nil t))) + (list (gnus-completing-read "Goto server" (mapcar 'car gnus-server-alist) t))) (let ((to (text-property-any (point-min) (point-max) 'gnus-server (intern server)))) (when to @@ -627,6 +612,18 @@ The following commands are available: (gnus-server-position-point)) 'edit-server))) +(defun gnus-server-show-server (server) + "Show the definition of the server on the current line." + (interactive (list (gnus-server-server-name))) + (unless server + (error "No server on current line")) + (let ((info (gnus-server-to-method server))) + (gnus-edit-form + info "Showing the server." + `(lambda (form) + (gnus-server-position-point)) + 'edit-server))) + (defun gnus-server-scan-server (server) "Request a scan from the current server." (interactive (list (gnus-server-server-name))) @@ -649,8 +646,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))))) @@ -667,6 +663,30 @@ The following commands are available: (defvar gnus-browse-menu-hook nil "*Hook run after the creation of the browse mode menu.") +(defcustom gnus-browse-subscribe-newsgroup-method + 'gnus-subscribe-alphabetically + "Function(s) called when subscribing groups in the Browse Server Buffer +A few pre-made functions are supplied: `gnus-subscribe-randomly' +inserts new groups at the beginning of the list of groups; +`gnus-subscribe-alphabetically' inserts new groups in strict +alphabetic order; `gnus-subscribe-hierarchically' inserts new groups +in hierarchical newsgroup order; `gnus-subscribe-interactively' asks +for your decision; `gnus-subscribe-killed' kills all new groups; +`gnus-subscribe-zombies' will make all new groups into zombies; +`gnus-subscribe-topics' will enter groups into the topics that +claim them." + :version "24.1" + :group 'gnus-server + :type '(radio (function-item gnus-subscribe-randomly) + (function-item gnus-subscribe-alphabetically) + (function-item gnus-subscribe-hierarchically) + (function-item gnus-subscribe-interactively) + (function-item gnus-subscribe-killed) + (function-item gnus-subscribe-zombies) + (function-item gnus-subscribe-topics) + function + (repeat function))) + (defvar gnus-browse-mode-hook nil) (defvar gnus-browse-mode-map nil) (put 'gnus-browse-mode 'mode-class 'special) @@ -747,7 +767,8 @@ The following commands are available: (with-current-buffer nntp-server-buffer (let ((cur (current-buffer))) (goto-char (point-min)) - (unless (string= gnus-ignored-newsgroups "") + (unless (or (null gnus-ignored-newsgroups) + (string= gnus-ignored-newsgroups "")) (delete-matching-lines gnus-ignored-newsgroups)) ;; We treat NNTP as a special case to avoid problems with ;; garbage group names like `"foo' that appear in some badly @@ -756,11 +777,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)) @@ -768,18 +790,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)) @@ -801,8 +824,6 @@ The following commands are available: (funcall gnus-group-prepare-function gnus-level-killed 'ignore 1 'ignore)) (gnus-get-buffer-create gnus-browse-buffer) - (when gnus-carpal - (gnus-carpal-setup-buffer 'browse)) (gnus-configure-windows 'browse) (buffer-disable-undo) (let ((buffer-read-only nil)) @@ -912,7 +933,9 @@ If NUMBER, fetch this number of articles." (gnus-browse-next-group (- n))) (defun gnus-browse-unsubscribe-current-group (arg) - "(Un)subscribe to the next ARG groups." + "(Un)subscribe to the next ARG groups. +The variable `gnus-browse-subscribe-newsgroup-method' determines +how new groups will be entered into the group buffer." (interactive "p") (when (eobp) (error "No group at current line")) @@ -961,22 +984,25 @@ If NUMBER, fetch this number of articles." ;; subscribe to it. (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 - (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)))) - (null (gnus-group-entry group))) + (let ((entry (gnus-group-entry group))) + (if entry + ;; Just change the subscription level if it is an + ;; unsubscribed group. + (gnus-group-change-level entry + gnus-level-default-subscribed) + ;; If it is a killed group or a zombie, feed it to the + ;; mechanism for new group subscription. + (gnus-call-subscribe-functions + gnus-browse-subscribe-newsgroup-method + group) + (gnus-request-update-group-status group 'subscribe))) (delete-char 1) - (insert ? )) + (insert (let ((lvl (gnus-group-level group))) + (cond + ((< lvl gnus-level-unsubscribed) ? ) + ((< lvl gnus-level-zombie) ?U) + ((< lvl gnus-level-killed) ?Z) + (t ?K))))) (gnus-group-change-level group gnus-level-unsubscribed gnus-level-default-subscribed) (delete-char 1) @@ -989,8 +1015,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) @@ -999,7 +1024,7 @@ If NUMBER, fetch this number of articles." (defun gnus-browse-describe-briefly () "Give a one line description of the group mode commands." (interactive) - (gnus-message 6 + (gnus-message 6 "%s" (substitute-command-keys "\\\\[gnus-group-next-group]:Forward \\[gnus-group-prev-group]:Backward \\[gnus-browse-exit]:Exit \\[gnus-info-find-node]:Run Info \\[gnus-browse-describe-briefly]:This help"))) (defun gnus-server-regenerate-server () @@ -1056,5 +1081,4 @@ Requesting compaction of %s... (this may take a long time)" (provide 'gnus-srvr) -;;; arch-tag: c0117f64-27ca-475d-9406-8da6854c7a25 ;;; gnus-srvr.el ends here