diff options
Diffstat (limited to 'lisp/gnus/gnus-srvr.el')
| -rw-r--r-- | lisp/gnus/gnus-srvr.el | 131 |
1 files changed, 47 insertions, 84 deletions
diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el index f4464ad140c..76a0f7d0fdb 100644 --- a/lisp/gnus/gnus-srvr.el +++ b/lisp/gnus/gnus-srvr.el @@ -24,7 +24,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gnus) (require 'gnus-start) @@ -36,11 +36,6 @@ (autoload 'gnus-group-make-nnir-group "nnir") -(defcustom gnus-server-mode-hook nil - "Hook run in `gnus-server-mode' buffers." - :group 'gnus-server - :type 'hook) - (defcustom gnus-server-exit-hook nil "Hook run when exiting the server buffer." :group 'gnus-server @@ -92,7 +87,7 @@ If nil, a faster, but more primitive, buffer is used instead." (defvar gnus-inserted-opened-servers nil) (defvar gnus-server-line-format-alist - `((?h gnus-tmp-how ?s) + '((?h gnus-tmp-how ?s) (?n gnus-tmp-name ?s) (?w gnus-tmp-where ?s) (?s gnus-tmp-status ?s) @@ -100,7 +95,7 @@ If nil, a faster, but more primitive, buffer is used instead." (?c gnus-tmp-cloud ?s))) (defvar gnus-server-mode-line-format-alist - `((?S gnus-tmp-news-server ?s) + '((?S gnus-tmp-news-server ?s) (?M gnus-tmp-news-method ?s) (?u gnus-tmp-user-defined ?s))) @@ -108,7 +103,7 @@ If nil, a faster, but more primitive, buffer is used instead." (defvar gnus-server-mode-line-format-spec nil) (defvar gnus-server-killed-servers nil) -(defvar gnus-server-mode-map) +(defvar gnus-server-mode-map nil) (defcustom gnus-server-menu-hook nil "Hook run after the creation of the server mode menu." @@ -142,7 +137,7 @@ If nil, a faster, but more primitive, buffer is used instead." ["Offline" gnus-server-offline-server t] ["Deny" gnus-server-deny-server t] ["Toggle Cloud Sync for this server" gnus-server-toggle-cloud-server t] - ["Toggle Cloud Sync Host" gnus-server-toggle-cloud-method-server t] + ["Toggle Cloud Sync Host" gnus-server-set-cloud-method-server t] "---" ["Open All" gnus-server-open-all-servers t] ["Close All" gnus-server-close-all-servers t] @@ -150,11 +145,8 @@ If nil, a faster, but more primitive, buffer is used instead." (gnus-run-hooks 'gnus-server-menu-hook))) -(defvar gnus-server-mode-map nil) -(put 'gnus-server-mode 'mode-class 'special) - (unless gnus-server-mode-map - (setq gnus-server-mode-map (make-sparse-keymap)) + (setq gnus-server-mode-map (make-keymap)) (suppress-keymap gnus-server-mode-map) (gnus-define-keys gnus-server-mode-map @@ -189,7 +181,7 @@ If nil, a faster, but more primitive, buffer is used instead." "z" gnus-server-compact-server "i" gnus-server-toggle-cloud-server - "I" gnus-server-toggle-cloud-method-server + "I" gnus-server-set-cloud-method-server "\C-c\C-i" gnus-info-find-node "\C-c\C-b" gnus-bug)) @@ -200,9 +192,6 @@ If nil, a faster, but more primitive, buffer is used instead." (t (:bold t))) "Face used for displaying AGENTIZED servers" :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-cloud '((((class color) (background light)) (:foreground "ForestGreen" :bold t)) @@ -224,9 +213,6 @@ If nil, a faster, but more primitive, buffer is used instead." (t (:bold t))) "Face used for displaying OPENED servers" :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)) @@ -235,9 +221,6 @@ If nil, a faster, but more primitive, buffer is used instead." (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)) @@ -245,9 +228,6 @@ If nil, a faster, but more primitive, buffer is used instead." (t (:inverse-video t :bold t))) "Face used for displaying DENIED servers" :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)) @@ -255,9 +235,6 @@ If nil, a faster, but more primitive, buffer is used instead." (t (:inverse-video t :bold t))) "Face used for displaying OFFLINE servers" :group 'gnus-server-visual) -;; backward-compatibility alias -(put 'gnus-server-offline-face 'face-alias 'gnus-server-offline) -(put 'gnus-server-offline-face 'obsolete-face "22.1") (defvar gnus-server-font-lock-keywords '(("(\\(agent\\))" 1 'gnus-server-agent) @@ -268,9 +245,8 @@ If nil, a faster, but more primitive, buffer is used instead." ("(\\(offline\\))" 1 'gnus-server-offline) ("(\\(denied\\))" 1 'gnus-server-denied))) -(defun gnus-server-mode () +(define-derived-mode gnus-server-mode gnus-mode "Server" "Major mode for listing and editing servers. - All normal editing commands are switched off. \\<gnus-server-mode-map> For more in-depth information on this mode, read the manual @@ -279,23 +255,16 @@ For more in-depth information on this mode, read the manual The following commands are available: \\{gnus-server-mode-map}" - ;; FIXME: Use define-derived-mode. - (interactive) (when (gnus-visual-p 'server-menu 'menu) (gnus-server-make-menu-bar)) - (kill-all-local-variables) (gnus-simplify-mode-line) - (setq major-mode 'gnus-server-mode) - (setq mode-name "Server") (gnus-set-default-directory) (setq mode-line-process nil) - (use-local-map gnus-server-mode-map) (buffer-disable-undo) (setq truncate-lines t) - (setq buffer-read-only t) (set (make-local-variable 'font-lock-defaults) - '(gnus-server-font-lock-keywords t)) - (gnus-run-mode-hooks 'gnus-server-mode-hook)) + '(gnus-server-font-lock-keywords t))) + (defun gnus-server-insert-server-line (name method) (let* ((gnus-tmp-name name) @@ -335,21 +304,15 @@ The following commands are available: (defun gnus-enter-server-buffer () "Set up the server buffer." - (gnus-server-setup-buffer) (gnus-configure-windows 'server) ;; 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) + (with-current-buffer (get-buffer-create gnus-server-buffer) + (gnus-server-mode) (gnus-server-prepare))) -(defun gnus-server-setup-buffer () - "Initialize the server buffer." - (unless (get-buffer gnus-server-buffer) - (with-current-buffer (gnus-get-buffer-create gnus-server-buffer) - (gnus-server-mode)))) - (defun gnus-server-prepare () (gnus-set-format 'server-mode) (gnus-set-format 'server t) @@ -452,7 +415,8 @@ The following commands are available: (if server (error "No such server: %s" server) (error "No server on the current line"))) (unless (assoc server gnus-server-alist) - (error "Read-only server %s" server)) + (error "Server %s must be deleted from your configuration files" + server)) (gnus-dribble-touch) (let ((buffer-read-only nil)) (gnus-delete-line)) @@ -608,7 +572,7 @@ The following commands are available: (error "%s already exists" to)) (unless (gnus-server-to-method from) (error "%s: no such server" from)) - (let ((to-entry (cons from (gnus-copy-sequence + (let ((to-entry (cons from (copy-tree (gnus-server-to-method from))))) (setcar to-entry to) (setcar (nthcdr 2 to-entry) to) @@ -642,7 +606,8 @@ The following commands are available: (unless server (error "No server on current line")) (unless (assoc server gnus-server-alist) - (error "This server can't be edited")) + (error "Server %s must be edited in your configuration files" + server)) (let ((info (cdr (assoc server gnus-server-alist)))) (gnus-close-server info) (gnus-edit-form @@ -661,8 +626,8 @@ The following commands are available: (let ((info (gnus-server-to-method server))) (gnus-edit-form info "Showing the server." - `(lambda (form) - (gnus-server-position-point)) + (lambda (form) + (gnus-server-position-point)) 'edit-server))) (defun gnus-server-scan-server (server) @@ -730,9 +695,7 @@ claim them." function (repeat function))) -(defvar gnus-browse-mode-hook nil) (defvar gnus-browse-mode-map nil) -(put 'gnus-browse-mode 'mode-class 'special) (unless gnus-browse-mode-map (setq gnus-browse-mode-map (make-keymap)) @@ -821,12 +784,11 @@ claim them." (while (not (eobp)) (ignore-errors (push (cons - (string-as-unibyte - (buffer-substring - (point) - (progn - (skip-chars-forward "^ \t") - (point)))) + (buffer-substring + (point) + (progn + (skip-chars-forward "^ \t") + (point))) (let ((last (read cur))) (cons (read cur) last))) groups)) @@ -834,19 +796,18 @@ claim them." (while (not (eobp)) (ignore-errors (push (cons - (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))) + (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)) @@ -912,9 +873,8 @@ claim them." (gnus-message 5 "Connecting to %s...done" (nth 1 method)) t)))) -(define-derived-mode gnus-browse-mode fundamental-mode "Browse Server" +(define-derived-mode gnus-browse-mode gnus-mode "Browse Server" "Major mode for browsing a foreign server. - All normal editing commands are switched off. \\<gnus-browse-mode-map> @@ -933,14 +893,17 @@ buffer. (setq mode-line-process nil) (buffer-disable-undo) (setq truncate-lines t) - (gnus-set-default-directory) - (setq buffer-read-only t)) + (gnus-set-default-directory)) (defun gnus-browse-read-group (&optional no-article number) "Enter the group at the current line. If NUMBER, fetch this number of articles." (interactive "P") - (let ((group (gnus-browse-group-name))) + (let* ((full-name (gnus-browse-group-name)) + (group (if (gnus-native-method-p + (gnus-find-method-for-group full-name)) + (gnus-group-short-name full-name) + full-name))) (if (or (not (gnus-get-info group)) (gnus-ephemeral-group-p group)) (unless (gnus-group-read-ephemeral-group @@ -982,7 +945,7 @@ how new groups will be entered into the group buffer." (not (eobp)) (gnus-browse-unsubscribe-group) (zerop (gnus-browse-next-group ward))) - (decf arg)) + (cl-decf arg)) (gnus-group-position-point) (when (/= 0 arg) (gnus-message 7 "No more newsgroups")) @@ -1127,7 +1090,7 @@ Requesting compaction of %s... (this may take a long time)" (and original (gnus-kill-buffer original)))))) (defun gnus-server-toggle-cloud-server () - "Make the server under point be replicated in the Emacs Cloud." + "Toggle whether the server under point is replicated in the Emacs Cloud." (interactive) (let ((server (gnus-server-server-name))) (unless server @@ -1147,7 +1110,7 @@ Requesting compaction of %s... (this may take a long time)" "Replication of %s in the cloud will stop") server))) -(defun gnus-server-toggle-cloud-method-server () +(defun gnus-server-set-cloud-method-server () "Set the server under point to host the Emacs Cloud." (interactive) (let ((server (gnus-server-server-name))) @@ -1157,7 +1120,7 @@ Requesting compaction of %s... (this may take a long time)" (error "The server under point can't host the Emacs Cloud")) (when (not (string-equal gnus-cloud-method server)) - (custom-set-variables '(gnus-cloud-method server)) + (customize-set-variable 'gnus-cloud-method server) ;; Note we can't use `Custom-save' here. (when (gnus-yes-or-no-p (format "The new cloud host server is %S now. Save it? " server)) |