diff options
Diffstat (limited to 'lisp/gnus/gnus-srvr.el')
| -rw-r--r-- | lisp/gnus/gnus-srvr.el | 79 |
1 files changed, 57 insertions, 22 deletions
diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el index 5874bd76085..6dbb54efb4a 100644 --- a/lisp/gnus/gnus-srvr.el +++ b/lisp/gnus/gnus-srvr.el @@ -32,6 +32,7 @@ (require 'gnus-group) (require 'gnus-int) (require 'gnus-range) +(require 'gnus-cloud) (autoload 'gnus-group-make-nnir-group "nnir") @@ -109,8 +110,10 @@ If nil, a faster, but more primitive, buffer is used instead." (defvar gnus-server-mode-map) -(defvar gnus-server-menu-hook nil - "*Hook run after the creation of the server mode menu.") +(defcustom gnus-server-menu-hook nil + "Hook run after the creation of the server mode menu." + :type 'hook + :group 'gnus-server) (defun gnus-server-make-menu-bar () (gnus-turn-off-edit-menu 'server) @@ -138,7 +141,8 @@ If nil, a faster, but more primitive, buffer is used instead." ["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] + ["Toggle Cloud Sync for this server" gnus-server-toggle-cloud-server t] + ["Toggle Cloud Sync Host" gnus-server-toggle-cloud-method-server t] "---" ["Open All" gnus-server-open-all-servers t] ["Close All" gnus-server-close-all-servers t] @@ -156,7 +160,7 @@ If nil, a faster, but more primitive, buffer is used instead." (gnus-define-keys gnus-server-mode-map " " gnus-server-read-server-in-server-buffer "\r" gnus-server-read-server - gnus-mouse-2 gnus-server-pick-server + [mouse-2] gnus-server-pick-server "q" gnus-server-exit "l" gnus-server-list-servers "k" gnus-server-kill-server @@ -185,6 +189,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 "\C-c\C-i" gnus-info-find-node "\C-c\C-b" gnus-bug)) @@ -203,7 +208,14 @@ If nil, a faster, but more primitive, buffer is used instead." '((((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" + "Face used for displaying Cloud-synced servers" + :group 'gnus-server-visual) + +(defface gnus-server-cloud-host + '((((class color) (background light)) (:foreground "ForestGreen" :inverse-video t :italic t)) + (((class color) (background dark)) (:foreground "PaleGreen" :inverse-video t :italic t)) + (t (:inverse-video t :italic t))) + "Face used for displaying the Cloud Host" :group 'gnus-server-visual) (defface gnus-server-opened @@ -249,7 +261,8 @@ If nil, a faster, but more primitive, buffer is used instead." (defvar gnus-server-font-lock-keywords '(("(\\(agent\\))" 1 'gnus-server-agent) - ("(\\(cloud\\))" 1 'gnus-server-cloud) + ("(\\(cloud[-]sync\\))" 1 'gnus-server-cloud) + ("(\\(CLOUD[-]HOST\\))" 1 'gnus-server-cloud-host) ("(\\(opened\\))" 1 'gnus-server-opened) ("(\\(closed\\))" 1 'gnus-server-closed) ("(\\(offline\\))" 1 'gnus-server-offline) @@ -280,10 +293,8 @@ The following commands are available: (buffer-disable-undo) (setq truncate-lines t) (setq buffer-read-only t) - (if (featurep 'xemacs) - (put 'gnus-server-mode 'font-lock-defaults '(gnus-server-font-lock-keywords t)) - (set (make-local-variable 'font-lock-defaults) - '(gnus-server-font-lock-keywords t))) + (set (make-local-variable 'font-lock-defaults) + '(gnus-server-font-lock-keywords t)) (gnus-run-mode-hooks 'gnus-server-mode-hook)) (defun gnus-server-insert-server-line (name method) @@ -306,11 +317,15 @@ The following commands are available: (gnus-agent-method-p method)) " (agent)" "")) - (gnus-tmp-cloud (if (gnus-cloud-server-p gnus-tmp-name) - " (cloud)" - ""))) + (gnus-tmp-cloud (concat + (if (gnus-cloud-host-server-p gnus-tmp-name) + " (CLOUD-HOST)" + "") + (if (gnus-cloud-server-p gnus-tmp-name) + " (cloud-sync)" + "")))) (beginning-of-line) - (gnus-add-text-properties + (add-text-properties (point) (prog1 (1+ (point)) ;; Insert the text. @@ -686,8 +701,10 @@ The following commands are available: ;;; Browse Server Mode ;;; -(defvar gnus-browse-menu-hook nil - "*Hook run after the creation of the browse mode menu.") +(defcustom gnus-browse-menu-hook nil + "Hook run after the creation of the browse mode menu." + :group 'gnus-server + :type 'hook) (defcustom gnus-browse-subscribe-newsgroup-method 'gnus-subscribe-alphabetically @@ -804,7 +821,7 @@ claim them." (while (not (eobp)) (ignore-errors (push (cons - (mm-string-as-unibyte + (string-as-unibyte (buffer-substring (point) (progn @@ -817,7 +834,7 @@ claim them." (while (not (eobp)) (ignore-errors (push (cons - (mm-string-as-unibyte + (string-as-unibyte (if (eq (char-after) ?\") (read cur) (let ((p (point)) (name "")) @@ -865,7 +882,7 @@ claim them." (prefix (let ((gnus-select-method orig-select-method)) (gnus-group-prefixed-name "" method)))) (while (setq group (pop groups)) - (gnus-add-text-properties + (add-text-properties (point) (prog1 (1+ (point)) (insert @@ -882,10 +899,9 @@ claim them." (t ?K))) (max 0 (- (1+ (cddr group)) (cadr group))) ;; Don't decode if name is ASCII - (if (and (fboundp 'detect-coding-string) - (eq (detect-coding-string name t) 'undecided)) + (if (eq (detect-coding-string name t) 'undecided) name - (mm-decode-coding-string + (decode-coding-string name (inline (gnus-group-name-charset method name))))))) (list 'gnus-group name) @@ -1131,6 +1147,25 @@ 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 () + "Set the server under point to host the Emacs Cloud." + (interactive) + (let ((server (gnus-server-server-name))) + (unless server + (error "No server on the current line")) + (unless (gnus-cloud-host-acceptable-method-p server) + (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)) + ;; 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)) + (customize-save-variable 'gnus-cloud-method server))) + (when (gnus-yes-or-no-p (format "Upload Cloud data to %S now? " server)) + (gnus-message 1 "Uploading all data to Emacs Cloud server %S" server) + (gnus-cloud-upload-data t)))) + (provide 'gnus-srvr) ;;; gnus-srvr.el ends here |