X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/6db1a873d5dbf13bf30376b16bcd83ebda269adc..30b3a842ec87d27cfe003b6d4323689d48b3fcd2:/lisp/gnus/gnus-srvr.el

diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el
index 5874bd7608..66fb9ee1b5 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,20 @@ 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"))
+
+    (custom-set-variables '(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