X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Friece-ctcp.el;h=0afefe8e8ad40a844d056aa2d52b1ce35c8d1728;hb=c70715e3dbe2d42b59e7048449a28851880f56e4;hp=f1fd937ca2d66bccdf0d98ddae2a667ade925d32;hpb=b51452a92d547fd23cd5bf0c28cca50963b89360;p=riece

diff --git a/lisp/riece-ctcp.el b/lisp/riece-ctcp.el
index f1fd937..0afefe8 100644
--- a/lisp/riece-ctcp.el
+++ b/lisp/riece-ctcp.el
@@ -1,4 +1,4 @@
-;;; riece-ctcp.el --- CTCP add-on
+;;; riece-ctcp.el --- CTCP (Client To Client Protocol) support
 ;; Copyright (C) 1998-2003 Daiki Ueno
 
 ;; Author: Daiki Ueno <ueno@unixuser.org>
@@ -22,12 +22,17 @@
 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 ;; Boston, MA 02111-1307, USA.
 
+;;; Commentary:
+
+;; NOTE: This is an add-on module for Riece.
+
 ;;; Code:
 
 (require 'riece-version)
 (require 'riece-misc)
 (require 'riece-highlight)
 (require 'riece-display)
+(require 'riece-debug)
 
 (defface riece-ctcp-action-face
   '((((class color)
@@ -49,27 +54,11 @@
 
 (defvar riece-dialogue-mode-map)
 
-(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)))
-  (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))
+(defconst riece-ctcp-description
+  "CTCP (Client To Client Protocol) support.")
 
 (defun riece-handle-ctcp-request (prefix string)
-  (when (and prefix string
+  (when (and (get 'riece-ctcp 'riece-addon-enabled) prefix string
 	     (riece-prefix-nickname prefix))
     (let* ((parameters (riece-split-parameters string))
 	   (targets (split-string (car parameters) ","))
@@ -86,27 +75,18 @@
 		  (after-hook
 		   (intern (concat "riece-ctcp-after-" request
 				   "-request-hook"))))
-	      (unless (condition-case error
-			  (run-hook-with-args-until-success
-			   hook prefix (car targets) message)
-			(error
-			 (if riece-debug
-			     (message "Error in `%S': %S" hook error))
-			 nil))
+	      (unless (riece-funcall-ignore-errors
+		       (symbol-name hook)
+		       #'run-hook-with-args-until-success
+		       hook prefix (car targets) message)
 		(if function
-		    (condition-case error
-			(funcall function prefix (car targets) message)
-		      (error
-		       (if riece-debug
-			   (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 in `%S': %S"
-			      after-hook error)))))
+		    (riece-funcall-ignore-errors (symbol-name function)
+						  function prefix (car targets)
+						  message))
+		(riece-funcall-ignore-errors (symbol-name after-hook)
+					     #'run-hook-with-args-until-success
+					     after-hook prefix (car targets)
+					     message)))
 	    t)))))
 
 (defun riece-handle-ctcp-version-request (prefix target string)
@@ -194,18 +174,52 @@
 		    (riece-channel-buffer (riece-make-identity
 					   target riece-server-name))))
 	(user (riece-prefix-nickname prefix)))
-    (riece-insert buffer (concat riece-ctcp-action-prefix user " " string
+    (riece-insert buffer (concat riece-ctcp-action-prefix
+				 (riece-format-identity
+				  (riece-make-identity user riece-server-name)
+				  t)
+				 " " 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 riece-ctcp-action-prefix user
-					       " " string)) "\n"))))
+     (concat (riece-concat-server-name
+	      (concat riece-ctcp-action-prefix
+		      (riece-format-identity
+		       (riece-make-identity target riece-server-name)
+		       t)
+		      ": "
+		      (riece-format-identity
+		       (riece-make-identity user riece-server-name)
+		       t)
+		      " " string)) "\n"))))
+
+(defun riece-handle-ctcp-time-request (prefix target string)
+  (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))
+	 (time (format-time-string "%c")))
+    (riece-send-string
+     (format "NOTICE %s :\1TIME %s\1\r\n" user time))
+    (riece-insert-change buffer (format "CTCP TIME from %s\n" user))
+    (riece-insert-change
+     (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
+       (format "CTCP TIME from %s (%s) to %s"
+	       user
+	       (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
+	       (riece-format-identity target-identity t)))
+      "\n"))))
 
 (defun riece-handle-ctcp-response (prefix string)
-  (when (and prefix string
+  (when (and (get 'riece-ctcp 'riece-addon-enabled) prefix string
 	     (riece-prefix-nickname prefix))
     (let* ((parameters (riece-split-parameters string))
 	   (targets (split-string (car parameters) ","))
@@ -221,27 +235,18 @@
 		  (after-hook
 		   (intern (concat "riece-ctcp-after-" response
 				   "-response-hook"))))
-	      (unless (condition-case error
-			  (run-hook-with-args-until-success
-			   hook prefix (car targets) message)
-			(error
-			 (if riece-debug
-			     (message "Error in `%S': %S" hook error))
-			 nil))
+	      (unless (riece-funcall-ignore-errors
+		       (symbol-name hook)
+		       #'run-hook-with-args-until-success
+		       hook prefix (car targets) message)
 		(if function
-		    (condition-case error
-			(funcall function prefix (car targets) message)
-		      (error
-		       (if riece-debug
-			   (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 in `%S': %S"
-			      after-hook error)))))
+		    (riece-funcall-ignore-errors
+		     (symbol-name function)
+		     function prefix (car targets) message))
+		(riece-funcall-ignore-errors (symbol-name after-hook)
+					     #'run-hook-with-args-until-success
+					     after-hook prefix (car targets)
+					     message)))
 	    t)))))
 
 (defun riece-handle-ctcp-version-response (prefix target string)
@@ -280,6 +285,17 @@
 	     string))
     "\n")))
 
+(defun riece-handle-ctcp-time-response (prefix target string)
+  (riece-insert-change
+   (list riece-dialogue-buffer riece-others-buffer)
+   (concat
+    (riece-concat-server-name
+     (format "CTCP TIME for %s (%s) = %s"
+	     (riece-prefix-nickname prefix)
+	     (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
+	     string))
+    "\n")))
+
 (defun riece-command-ctcp-version (target)
   (interactive
    (list (riece-completing-read-identity
@@ -340,10 +356,57 @@
       (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) ")")))
+		 (riece-format-identity target t) ": "
+		 (riece-identity-prefix (riece-current-nickname)) " " action)))
       "\n"))))
 
+(defun riece-command-ctcp-time (target)
+  (interactive
+   (list (riece-completing-read-identity
+	  "Channel/User: "
+	  (riece-get-identities-on-server (riece-current-server-name)))))
+  (riece-send-string (format "PRIVMSG %s :\1TIME\1\r\n"
+			     (riece-identity-prefix target))))
+
+(defun riece-ctcp-requires ()
+  (if (memq 'riece-highlight riece-addons)
+      '(riece-highlight)))
+
+(defvar riece-ctcp-dialogue-font-lock-keywords
+  (list (concat "^" riece-time-prefix-regexp "\\("
+		(regexp-quote riece-ctcp-action-prefix)
+		".*\\)$")
+	1 riece-ctcp-action-face t t))
+
+(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 riece-ctcp-dialogue-font-lock-keywords
+		  riece-dialogue-font-lock-keywords))))
+
+(defun riece-ctcp-uninstall ()
+  (remove-hook 'riece-privmsg-hook 'riece-handle-ctcp-request)
+  (remove-hook 'riece-notice-hook 'riece-handle-ctcp-response)
+  (setq riece-dialogue-font-lock-keywords
+	(delq riece-ctcp-dialogue-font-lock-keywords
+	      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)
+  (define-key riece-dialogue-mode-map "\C-ct" 'riece-command-ctcp-time))
+
+(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)
+  (define-key riece-dialogue-mode-map "\C-ct" nil))
+
 (provide 'riece-ctcp)
 
 ;;; riece-ctcp.el ends here