X-Git-Url: https://cgit.sxemacs.org/?p=riece;a=blobdiff_plain;f=lisp%2Friece-ctcp.el;h=5fc14e0bc0923f7833136e99d5f78db3fb4c92b6;hp=240c9ac8e17f7c08b6dd8aa92d36f9d16e1b90ab;hb=2d67acd4af1122a36fcc09b47a479b927ca03904;hpb=9174f38ace6e8cd879b41adc4d6aa4b5b727f7ea

diff --git a/lisp/riece-ctcp.el b/lisp/riece-ctcp.el
index 240c9ac..5fc14e0 100644
--- a/lisp/riece-ctcp.el
+++ b/lisp/riece-ctcp.el
@@ -26,23 +26,36 @@
 
 (require 'riece-version)
 (require 'riece-misc)
+(require 'riece-highlight)
 (require 'riece-display)
 
+(defface riece-ctcp-action-face
+  '((((class color)
+      (background dark))
+     (:foreground "PaleGreen" :italic t))
+    (((class color)
+      (background light))
+     (:foreground "ForestGreen" :italic t))
+    (t
+     (:bold t)))
+  "Face used for displaying \"*** Action:\" line"
+  :group 'riece-highlight-faces)
+(defvar riece-ctcp-action-face 'riece-ctcp-action-face)
+
+(defconst riece-ctcp-action-prefix "*** Action: ")
+
 (defvar riece-ctcp-ping-time nil)
 (defvar riece-ctcp-additional-clientinfo nil)
 
 (defvar riece-dialogue-mode-map)
 
-(defun riece-ctcp-insinuate ()
-  (add-hook 'riece-privmsg-hook 'riece-handle-ctcp-request)
-  (add-hook 'riece-notice-hook 'riece-handle-ctcp-response)
-  (define-key riece-dialogue-mode-map "\C-cv" 'riece-command-ctcp-version)
-  (define-key riece-dialogue-mode-map "\C-cp" 'riece-command-ctcp-ping)
-  (define-key riece-dialogue-mode-map "\C-ca" 'riece-command-ctcp-action)
-  (define-key riece-dialogue-mode-map "\C-cc" 'riece-command-ctcp-clientinfo))
+(defvar riece-ctcp-enabled nil)
+
+(defconst riece-ctcp-description
+  "CTCP (Client To Client Protocol) support")
 
 (defun riece-handle-ctcp-request (prefix string)
-  (when (and prefix string
+  (when (and riece-ctcp-enabled prefix string
 	     (riece-prefix-nickname prefix))
     (let* ((parameters (riece-split-parameters string))
 	   (targets (split-string (car parameters) ","))
@@ -64,29 +77,29 @@
 			   hook prefix (car targets) message)
 			(error
 			 (if riece-debug
-			     (message "Error occurred in `%S': %S" hook error))
+			     (message "Error in `%S': %S" hook error))
 			 nil))
 		(if function
 		    (condition-case error
 			(funcall function prefix (car targets) message)
 		      (error
 		       (if riece-debug
-			   (message "Error occurred in `%S': %S"
+			   (message "Error in `%S': %S"
 				    function error))))))
 	      (condition-case error
 		  (run-hook-with-args-until-success
 		   after-hook prefix (car targets) message)
 		(error
 		 (if riece-debug
-		     (message "Error occurred in `%S': %S"
+		     (message "Error in `%S': %S"
 			      after-hook error)))))
 	    t)))))
 
 (defun riece-handle-ctcp-version-request (prefix target string)
-  (let ((buffer (if (riece-channel-p target)
-		    (riece-channel-buffer (riece-make-identity
-					   target riece-server-name))))
-	(user (riece-prefix-nickname prefix)))
+  (let* ((target-identity (riece-make-identity target riece-server-name))
+	 (buffer (if (riece-channel-p target)
+		     (riece-channel-buffer target-identity)))
+	 (user (riece-prefix-nickname prefix)))
     (riece-send-string
      (format "NOTICE %s :\1VERSION %s\1\r\n" user (riece-extended-version)))
     (riece-insert-change buffer (format "CTCP VERSION from %s\n" user))
@@ -100,14 +113,14 @@
        (format "CTCP VERSION from %s (%s) to %s"
 	       user
 	       (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
-	       target))
+	       (riece-format-identity target-identity t)))
       "\n"))))
 
 (defun riece-handle-ctcp-ping-request (prefix target string)
-  (let ((buffer (if (riece-channel-p target)
-		    (riece-channel-buffer (riece-make-identity
-					   target riece-server-name))))
-	(user (riece-prefix-nickname prefix)))
+  (let* ((target-identity (riece-make-identity target riece-server-name))
+	 (buffer (if (riece-channel-p target)
+		     (riece-channel-buffer target-identity)))
+	 (user (riece-prefix-nickname prefix)))
     (riece-send-string
      (if string
 	 (format "NOTICE %s :\1PING %s\1\r\n" user string)
@@ -123,14 +136,14 @@
        (format "CTCP PING from %s (%s) to %s"
 	       user
 	       (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
-	       target))
+	       (riece-format-identity target-identity t)))
       "\n"))))
 
 (defun riece-handle-ctcp-clientinfo-request (prefix target string)
-  (let ((buffer (if (riece-channel-p target)
-		    (riece-channel-buffer (riece-make-identity
-					   target riece-server-name))))
-	(user (riece-prefix-nickname prefix)))
+  (let* ((target-identity (riece-make-identity target riece-server-name))
+	 (buffer (if (riece-channel-p target)
+		     (riece-channel-buffer target-identity)))
+	 (user (riece-prefix-nickname prefix)))
     (riece-send-string
      (format "NOTICE %s :\1CLIENTINFO %s\1\r\n"
 	     user
@@ -159,7 +172,7 @@
        (format "CTCP CLIENTINFO from %s (%s) to %s"
 	       user
 	       (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
-	       target))
+	       (riece-format-identity target-identity t)))
       "\n"))))
 
 (defun riece-handle-ctcp-action-request (prefix target string)
@@ -167,16 +180,18 @@
 		    (riece-channel-buffer (riece-make-identity
 					   target riece-server-name))))
 	(user (riece-prefix-nickname prefix)))
-    (riece-insert-change buffer (concat user " " string "\n"))
-    (riece-insert-change
+    (riece-insert buffer (concat riece-ctcp-action-prefix user " " string
+				 "\n"))
+    (riece-insert
      (if (and riece-channel-buffer-mode
 	      (not (eq buffer riece-channel-buffer)))
 	 (list riece-dialogue-buffer riece-others-buffer)
        riece-dialogue-buffer)
-     (concat (riece-concat-server-name (concat user " " string)) "\n"))))
+     (concat (riece-concat-server-name (concat riece-ctcp-action-prefix user
+					       " " string)) "\n"))))
 
 (defun riece-handle-ctcp-response (prefix string)
-  (when (and prefix string
+  (when (and riece-ctcp-enabled prefix string
 	     (riece-prefix-nickname prefix))
     (let* ((parameters (riece-split-parameters string))
 	   (targets (split-string (car parameters) ","))
@@ -197,21 +212,21 @@
 			   hook prefix (car targets) message)
 			(error
 			 (if riece-debug
-			     (message "Error occurred in `%S': %S" hook error))
+			     (message "Error in `%S': %S" hook error))
 			 nil))
 		(if function
 		    (condition-case error
 			(funcall function prefix (car targets) message)
 		      (error
 		       (if riece-debug
-			   (message "Error occurred in `%S': %S"
+			   (message "Error in `%S': %S"
 				    function error))))))
 	      (condition-case error
 		  (run-hook-with-args-until-success
 		   after-hook prefix (car targets) message)
 		(error
 		 (if riece-debug
-		     (message "Error occurred in `%S': %S"
+		     (message "Error in `%S': %S"
 			      after-hook error)))))
 	    t)))))
 
@@ -251,59 +266,99 @@
 	     string))
     "\n")))
 
-(defun riece-command-ctcp-version (user)
+(defun riece-command-ctcp-version (target)
   (interactive
-   (let ((completion-ignore-case t))
-     (list (completing-read
-	    "Channel/User: "
-	    (mapcar #'list (riece-get-users-on-server))))))
-  (riece-send-string (format "PRIVMSG %s :\1VERSION\1\r\n" user)))
+   (list (riece-completing-read-identity
+	  "Channel/User: "
+	  (riece-get-identities-on-server (riece-current-server-name)))))
+  (riece-send-string (format "PRIVMSG %s :\1VERSION\1\r\n"
+			     (riece-identity-prefix target))))
 
-(defun riece-command-ctcp-ping (user)
+(defun riece-command-ctcp-ping (target)
   (interactive
-   (let ((completion-ignore-case t))
-     (list (completing-read
-	    "Channel/User: "
-	    (mapcar #'list (riece-get-users-on-server))))))
-  (riece-send-string (format "PRIVMSG %s :\1PING\1\r\n" user))
+   (list (riece-completing-read-identity
+	  "Channel/User: "
+	  (riece-get-identities-on-server (riece-current-server-name)))))
+  (riece-send-string (format "PRIVMSG %s :\1PING\1\r\n"
+			     (riece-identity-prefix target)))
   (setq riece-ctcp-ping-time (current-time)))
 
-(defun riece-command-ctcp-clientinfo (user)
+(defun riece-command-ctcp-clientinfo (target)
   (interactive
-   (let ((completion-ignore-case t))
-     (list (completing-read
-	    "Channel/User: "
-	    (mapcar #'list (riece-get-users-on-server))))))
-  (riece-send-string (format "PRIVMSG %s :\1CLIENTINFO\1\r\n" user)))
+   (list (riece-completing-read-identity
+	  "Channel/User: "
+	  (riece-get-identities-on-server (riece-current-server-name)))))
+  (riece-send-string (format "PRIVMSG %s :\1CLIENTINFO\1\r\n"
+			     (riece-identity-prefix target))))
 
-(defun riece-command-ctcp-action (channel action)
+(defun riece-command-ctcp-action (target action)
   (interactive
    (list (if current-prefix-arg
-	     (completing-read
+	     (riece-completing-read-identity
 	      "Channel/User: "
-	      (mapcar #'list riece-current-channels))
+	      (riece-get-identities-on-server (riece-current-server-name)))
 	   riece-current-channel)
-	 (read-string "Action: ")))
+	 (let (message)
+	   (beginning-of-line)
+	   (setq message (buffer-substring (point)
+					   (progn (end-of-line) (point))))
+	   (if (equal message "")
+	       (read-string "Action: ")
+	     (prog1 (read-from-minibuffer "Action: " (cons message 0))
+	       (let ((next-line-add-newlines t))
+		 (next-line 1)))))))
   (if (equal action "")
       (error "No action"))
   (riece-send-string (format "PRIVMSG %s :\1ACTION %s\1\r\n"
-			     (riece-identity-prefix channel)
+			     (riece-identity-prefix target)
 			     action))
-  (let ((buffer (riece-channel-buffer (riece-make-identity
-				       channel riece-server-name))))
-    (riece-insert-change
+  (let ((buffer (riece-channel-buffer target)))
+    (riece-insert
      buffer
-     (concat (riece-identity-prefix (riece-current-nickname)) " " action "\n"))
-    (riece-insert-change
+     (concat riece-ctcp-action-prefix
+	     (riece-identity-prefix (riece-current-nickname)) " " action "\n"))
+    (riece-insert
      (if (and riece-channel-buffer-mode
 	      (not (eq buffer riece-channel-buffer)))
 	 (list riece-dialogue-buffer riece-others-buffer)
        riece-dialogue-buffer)
      (concat
-      (riece-concat-server-name
-       (concat (riece-identity-prefix (riece-current-nickname)) " " action))
+      (riece-with-server-buffer (riece-identity-server target)
+	(riece-concat-server-name
+	 (concat riece-ctcp-action-prefix
+		 (riece-identity-prefix (riece-current-nickname)) " " action
+		 " (in " (riece-format-identity target t) ")")))
       "\n"))))
 
+(defun riece-ctcp-requires ()
+  (if (memq 'riece-highlight riece-addons)
+      '(riece-highlight)))
+
+(defun riece-ctcp-insinuate ()
+  (add-hook 'riece-privmsg-hook 'riece-handle-ctcp-request)
+  (add-hook 'riece-notice-hook 'riece-handle-ctcp-response)
+  (if (memq 'riece-highlight riece-addons)
+      (setq riece-dialogue-font-lock-keywords
+	    (cons (list (concat "^" riece-time-prefix-regexp "\\("
+				(regexp-quote riece-ctcp-action-prefix)
+				".*\\)$")
+			1 riece-ctcp-action-face t t)
+		  riece-dialogue-font-lock-keywords))))
+
+(defun riece-ctcp-enable ()
+  (define-key riece-dialogue-mode-map "\C-cv" 'riece-command-ctcp-version)
+  (define-key riece-dialogue-mode-map "\C-cp" 'riece-command-ctcp-ping)
+  (define-key riece-dialogue-mode-map "\C-ca" 'riece-command-ctcp-action)
+  (define-key riece-dialogue-mode-map "\C-cc" 'riece-command-ctcp-clientinfo)
+  (setq riece-ctcp-enabled t))
+
+(defun riece-ctcp-disable ()
+  (define-key riece-dialogue-mode-map "\C-cv" nil)
+  (define-key riece-dialogue-mode-map "\C-cp" nil)
+  (define-key riece-dialogue-mode-map "\C-ca" nil)
+  (define-key riece-dialogue-mode-map "\C-cc" nil)
+  (setq riece-ctcp-enabled nil))
+
 (provide 'riece-ctcp)
 
 ;;; riece-ctcp.el ends here