;;; gnus-srvr.el --- virtual server support for Gnus
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1995-2015 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
(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
:group 'gnus-server
:type 'hook)
-(defcustom gnus-server-line-format " {%(%h:%w%)} %s%a\n"
+(defcustom gnus-server-line-format " {%(%h:%w%)} %s%a%c\n"
"Format of server lines.
It works along the same lines as a normal formatting string,
with some simple extensions.
;;; Internal variables.
+(defvar gnus-tmp-how)
+(defvar gnus-tmp-name)
+(defvar gnus-tmp-where)
+(defvar gnus-tmp-status)
+(defvar gnus-tmp-agent)
+(defvar gnus-tmp-cloud)
+(defvar gnus-tmp-news-server)
+(defvar gnus-tmp-news-method)
+(defvar gnus-tmp-user-defined)
+
(defvar gnus-inserted-opened-servers nil)
(defvar gnus-server-line-format-alist
(?n gnus-tmp-name ?s)
(?w gnus-tmp-where ?s)
(?s gnus-tmp-status ?s)
- (?a gnus-tmp-agent ?s)))
+ (?a gnus-tmp-agent ?s)
+ (?c gnus-tmp-cloud ?s)))
(defvar gnus-server-mode-line-format-alist
`((?S gnus-tmp-news-server ?s)
["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]
["Close" gnus-server-close-server t]
["Offline" gnus-server-offline-server t]
["Deny" gnus-server-deny-server t]
+ ["Toggle Cloud" gnus-server-toggle-cloud-server t]
"---"
["Open All" gnus-server-open-all-servers t]
["Close All" gnus-server-close-all-servers t]
"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
"g" gnus-server-regenerate-server
+ "G" gnus-group-make-nnir-group
+
"z" gnus-server-compact-server
+ "i" gnus-server-toggle-cloud-server
+
"\C-c\C-i" gnus-info-find-node
"\C-c\C-b" gnus-bug))
(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))
+ (((class color) (background dark)) (:foreground "PaleGreen" :bold t))
+ (t (:bold t)))
+ "Face used for displaying AGENTIZED servers"
+ :group 'gnus-server-visual)
+
(defface gnus-server-opened
'((((class color) (background light)) (:foreground "Green3" :bold t))
(((class color) (background dark)) (:foreground "Green1" :bold t))
(defvar gnus-server-font-lock-keywords
'(("(\\(agent\\))" 1 'gnus-server-agent)
+ ("(\\(cloud\\))" 1 'gnus-server-cloud)
("(\\(opened\\))" 1 'gnus-server-opened)
("(\\(closed\\))" 1 'gnus-server-closed)
("(\\(offline\\))" 1 'gnus-server-offline)
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))
'(gnus-server-font-lock-keywords t)))
(gnus-run-mode-hooks 'gnus-server-mode-hook))
-(defun gnus-server-insert-server-line (gnus-tmp-name method)
- (let* ((gnus-tmp-how (car method))
+(defun gnus-server-insert-server-line (name method)
+ (let* ((gnus-tmp-name name)
+ (gnus-tmp-how (car method))
(gnus-tmp-where (nth 1 method))
(elem (assoc method gnus-opened-servers))
(gnus-tmp-status
(gnus-tmp-agent (if (and gnus-agent
(gnus-agent-method-p method))
" (agent)"
+ ""))
+ (gnus-tmp-cloud (if (gnus-cloud-server-p gnus-tmp-name)
+ " (cloud)"
"")))
(beginning-of-line)
(gnus-add-text-properties
"Initialize the server buffer."
(unless (get-buffer gnus-server-buffer)
(with-current-buffer (gnus-get-buffer-create gnus-server-buffer)
- (gnus-server-mode)
- (when gnus-carpal
- (gnus-carpal-setup-buffer 'server)))))
+ (gnus-server-mode))))
(defun gnus-server-prepare ()
(gnus-set-format 'server-mode)
(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))))
(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
(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)))
(error "No such server: %s" server))
(gnus-server-set-status method 'ok)
(prog1
- (or (gnus-open-server method)
- (progn (message "Couldn't open %s" server) nil))
+ (gnus-open-server method)
(gnus-server-update-server server)
(gnus-server-position-point))))
(gnus-server-list-servers))
(defun gnus-server-copy-server (from to)
- "Copy a server definiton to a new name."
+ "Copy a server definition to a new name."
(interactive
(list
(or (gnus-server-server-name)
(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"))
(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
(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)))
(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)
"q" gnus-browse-exit
"Q" gnus-browse-exit
"d" gnus-browse-describe-group
+ [delete] gnus-browse-delete-group
"\C-c\C-c" gnus-browse-exit
"?" gnus-browse-describe-briefly
(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
(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))
(gnus-message 5 "Connecting to %s...done" (nth 1 method))
t))))
-(defun gnus-browse-mode ()
+(define-derived-mode gnus-browse-mode fundamental-mode "Browse Server"
"Major mode for browsing a foreign server.
All normal editing commands are switched off.
2) `\\[gnus-browse-read-group]' to read a group ephemerally.
3) `\\[gnus-browse-exit]' to return to the group buffer."
- (interactive)
- (kill-all-local-variables)
(when (gnus-visual-p 'browse-menu 'menu)
(gnus-browse-make-menu-bar))
(gnus-simplify-mode-line)
- (setq major-mode 'gnus-browse-mode)
- (setq mode-name "Browse Server")
(setq mode-line-process nil)
- (use-local-map gnus-browse-mode-map)
(buffer-disable-undo)
(setq truncate-lines t)
(gnus-set-default-directory)
- (setq buffer-read-only t)
- (gnus-run-mode-hooks 'gnus-browse-mode-hook))
+ (setq buffer-read-only t))
(defun gnus-browse-read-group (&optional no-article number)
"Enter the group at the current line.
(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"))
(interactive (list (gnus-browse-group-name)))
(gnus-group-describe-group nil group))
+(defun gnus-browse-delete-group (group force)
+ "Delete the current group. Only meaningful with editable groups.
+If FORCE (the prefix) is non-nil, all the articles in the group will
+be deleted. This is \"deleted\" as in \"removed forever from the face
+of the Earth\". There is no undo. The user will be prompted before
+doing the deletion."
+ (interactive (list (gnus-browse-group-name)
+ current-prefix-arg))
+ (gnus-group-delete-group group force))
+
(defun gnus-browse-unsubscribe-group ()
"Toggle subscription of the current group in the browse buffer."
(let ((sub nil)
;; 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)
(defun gnus-browse-exit ()
"Quit browsing and return to the group buffer."
(interactive)
- (when (eq major-mode 'gnus-browse-mode)
+ (when (derived-mode-p 'gnus-browse-mode)
(gnus-kill-buffer (current-buffer)))
;; Insert the newly subscribed groups in the group buffer.
(with-current-buffer gnus-group-buffer
(let ((original (get-buffer gnus-original-article-buffer)))
(and original (gnus-kill-buffer original))))))
+(defun gnus-server-toggle-cloud-server ()
+ "Make the server under point be replicated in the Emacs Cloud."
+ (interactive)
+ (let ((server (gnus-server-server-name)))
+ (unless server
+ (error "No server on the current line"))
+
+ (unless (gnus-method-option-p server 'cloud)
+ (error "The server under point doesn't support cloudiness"))
+
+ (if (gnus-cloud-server-p server)
+ (setq gnus-cloud-covered-servers
+ (delete server gnus-cloud-covered-servers))
+ (push server gnus-cloud-covered-servers))
+
+ (gnus-server-update-server server)
+ (gnus-message 1 (if (gnus-cloud-server-p server)
+ "Replication of %s in the cloud will start"
+ "Replication of %s in the cloud will stop")
+ server)))
+
(provide 'gnus-srvr)
;;; gnus-srvr.el ends here
projects / gnus / blobdiff