X-Git-Url: http://cgit.sxemacs.org/?p=riece;a=blobdiff_plain;f=lisp%2Friece-ctcp.el;h=18eefdc6b6626aaaf5393c4dd13894a943566b72;hp=8c8ba1ce9c15ff3f7adb1aeeeb736f9019e159a0;hb=826060119507d6fa0e22c4344863fb776759597f;hpb=0746817f15bbeda3c5387e02a20a11b8aa967701 diff --git a/lisp/riece-ctcp.el b/lisp/riece-ctcp.el index 8c8ba1c..18eefdc 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 @@ -19,15 +19,22 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; NOTE: This is an add-on module for Riece. ;;; Code: (require 'riece-version) (require 'riece-misc) -(require 'riece-display) (require 'riece-highlight) +(require 'riece-display) +(require 'riece-debug) +(require 'riece-mcat) +(require 'riece-message) (defface riece-ctcp-action-face '((((class color) @@ -49,27 +56,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,34 +77,25 @@ (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 occurred 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 occurred 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" - 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) - (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)) @@ -124,21 +106,21 @@ riece-dialogue-buffer) (concat (riece-concat-server-name - (format "CTCP VERSION from %s (%s) to %s" + (format (riece-mcat "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) - (format "NOTICE %s :\1PING\1\r\n" user string))) + (format "NOTICE %s :\1PING\1\r\n" user))) (riece-insert-change buffer (format "CTCP PING from %s\n" user)) (riece-insert-change (if (and riece-channel-buffer-mode @@ -147,17 +129,17 @@ riece-dialogue-buffer) (concat (riece-concat-server-name - (format "CTCP PING from %s (%s) to %s" + (format (riece-mcat "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 @@ -183,29 +165,67 @@ riece-dialogue-buffer) (concat (riece-concat-server-name - (format "CTCP CLIENTINFO from %s (%s) to %s" + (format (riece-mcat "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-ctcp-action-format-message (message &optional global) + (riece-with-server-buffer (riece-identity-server + (riece-message-speaker message)) + (concat + (if global + (riece-concat-server-name + (concat riece-ctcp-action-prefix + (riece-format-identity (riece-message-target message) t) ": " + (riece-identity-prefix (riece-message-speaker message)) " " + (riece-message-text message))) + (concat riece-ctcp-action-prefix + (riece-identity-prefix (riece-message-speaker message)) " " + (riece-message-text message))) + "\n"))) + (defun riece-handle-ctcp-action-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))) - (riece-insert buffer (concat riece-ctcp-action-prefix user " " string - "\n")) - (riece-insert + (riece-display-message + (riece-make-message (riece-make-identity user + riece-server-name) + (riece-make-identity target + riece-server-name) + string + 'action + (riece-identity-equal-no-server + user riece-real-nickname))))) + +(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 (riece-mcat "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 (concat riece-ctcp-action-prefix user - " " string)) "\n")))) + (concat + (riece-concat-server-name + (format (riece-mcat "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 +241,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 occurred 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 occurred 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" - 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) @@ -249,7 +260,7 @@ (list riece-dialogue-buffer riece-others-buffer) (concat (riece-concat-server-name - (format "CTCP VERSION for %s (%s) = %s" + (format (riece-mcat "CTCP VERSION for %s (%s) = %s") (riece-prefix-nickname prefix) (riece-strip-user-at-host (riece-prefix-user-at-host prefix)) string)) @@ -263,7 +274,7 @@ (list riece-dialogue-buffer riece-others-buffer) (concat (riece-concat-server-name - (format "CTCP PING for %s (%s) = %d sec" + (format (riece-mcat "CTCP PING for %s (%s) = %d sec") (riece-prefix-nickname prefix) (riece-strip-user-at-host (riece-prefix-user-at-host prefix)) elapsed)) @@ -274,7 +285,18 @@ (list riece-dialogue-buffer riece-others-buffer) (concat (riece-concat-server-name - (format "CTCP CLIENTINFO for %s (%s) = %s" + (format (riece-mcat "CTCP CLIENTINFO for %s (%s) = %s") + (riece-prefix-nickname prefix) + (riece-strip-user-at-host (riece-prefix-user-at-host prefix)) + 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 (riece-mcat "CTCP TIME for %s (%s) = %s") (riece-prefix-nickname prefix) (riece-strip-user-at-host (riece-prefix-user-at-host prefix)) string)) @@ -283,7 +305,7 @@ (defun riece-command-ctcp-version (target) (interactive (list (riece-completing-read-identity - "Channel/User: " + (riece-mcat "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)))) @@ -291,7 +313,7 @@ (defun riece-command-ctcp-ping (target) (interactive (list (riece-completing-read-identity - "Channel/User: " + (riece-mcat "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))) @@ -300,7 +322,7 @@ (defun riece-command-ctcp-clientinfo (target) (interactive (list (riece-completing-read-identity - "Channel/User: " + (riece-mcat "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)))) @@ -309,7 +331,7 @@ (interactive (list (if current-prefix-arg (riece-completing-read-identity - "Channel/User: " + (riece-mcat "Channel/User: ") (riece-get-identities-on-server (riece-current-server-name))) riece-current-channel) (let (message) @@ -317,32 +339,69 @@ (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))))))) + (read-string (riece-mcat "Action: ")) + (prog1 (read-from-minibuffer (riece-mcat "Action: ") + (cons message 0)) + (if (> (forward-line) 0) + (insert "\n"))))))) (if (equal action "") (error "No action")) (riece-send-string (format "PRIVMSG %s :\1ACTION %s\1\r\n" (riece-identity-prefix target) action)) - (let ((buffer (riece-channel-buffer target))) - (riece-insert - buffer - (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-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")))) + (riece-display-message + (riece-make-message (riece-current-nickname) target action 'action t))) + +(defun riece-command-ctcp-time (target) + (interactive + (list (riece-completing-read-identity + (riece-mcat "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))) + (unless (assq 'action riece-message-format-function-alist) + (setq riece-message-format-function-alist + (cons (cons 'action #'riece-ctcp-action-format-message) + riece-message-format-function-alist)))) + +(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)