X-Git-Url: https://cgit.sxemacs.org/?p=riece;a=blobdiff_plain;f=lisp%2Friece-ctcp.el;h=45eebf826c312df0089b34c4757c0e1a2308ca3a;hp=4bd4101c9d402c58249cf94413484006c6aa331f;hb=652251a551d5450e780b07f70f0347507f19de3a;hpb=de84f5bf7c17c10bfd85c547bb3cf7a29234857d diff --git a/lisp/riece-ctcp.el b/lisp/riece-ctcp.el index 4bd4101..45eebf8 100644 --- a/lisp/riece-ctcp.el +++ b/lisp/riece-ctcp.el @@ -26,52 +26,70 @@ (require 'riece-version) (require 'riece-misc) +(require 'riece-highlight) +(require 'riece-display) +(require 'riece-debug) + +(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)) +(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* ((user (riece-prefix-nickname prefix)) - (parameters (riece-split-parameters string)) + (let* ((parameters (riece-split-parameters string)) (targets (split-string (car parameters) ",")) (message (nth 1 parameters))) (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message) (let ((request (downcase (match-string 1 message)))) (if (match-beginning 2) (setq message (substring (match-string 2 message) 1))) - (unless (run-hook-with-args-until-success - (intern (concat "riece-ctcp-" request "-request-hook")) - prefix (car targets) message) - (let ((function (intern-soft (concat "riece-handle-ctcp-" - request - "-request")))) + (let ((hook + (intern (concat "riece-ctcp-" request "-request-hook"))) + (function + (intern-soft (concat "riece-handle-ctcp-" request + "-request"))) + (after-hook + (intern (concat "riece-ctcp-after-" request + "-request-hook")))) + (unless (riece-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)))))) - (run-hook-with-args-until-success - (intern (concat "riece-ctcp-after-" request "-request-hook")) - prefix (car targets) message)) + (riece-funcall-ignore-errors (symbol-name function) + function prefix (car targets) + message)) + (riece-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) - (cdr (riece-identity-assoc-no-server - (riece-make-identity target) - riece-channel-buffer-alist)))) - (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)) @@ -85,15 +103,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) - (cdr (riece-identity-assoc-no-server - (riece-make-identity target) - riece-channel-buffer-alist)))) - (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) @@ -109,36 +126,121 @@ (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* ((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 + (let (messages) + (mapatoms + (lambda (atom) + (let ((case-fold-search t)) + (if (and (fboundp atom) + (string-match + "riece-handle-ctcp-\\(.+\\)-request" + (symbol-name atom))) + (setq messages + (cons (match-string 1 (symbol-name atom)) + messages)))))) + (mapconcat #'upcase (append messages + riece-ctcp-additional-clientinfo) + " ")))) + (riece-insert-change buffer (format "CTCP CLIENTINFO 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 CLIENTINFO 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-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 + (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 + (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 riece-ctcp-enabled prefix string (riece-prefix-nickname prefix)) - (let* ((user (riece-prefix-nickname prefix)) - (parameters (riece-split-parameters string)) + (let* ((parameters (riece-split-parameters string)) (targets (split-string (car parameters) ",")) (message (nth 1 parameters))) (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message) (let ((response (downcase (match-string 1 message)))) (if (match-beginning 2) (setq message (substring (match-string 2 message) 1))) - (unless (run-hook-with-args-until-success - (intern (concat "riece-ctcp-" response "-response-hook")) - prefix (car targets) message) - (let ((function (intern-soft (concat "riece-handle-ctcp-" - response - "-response")))) + (let ((hook + (intern (concat "riece-ctcp-" response "-response-hook"))) + (function (intern-soft (concat "riece-handle-ctcp-" + response "-response"))) + (after-hook + (intern (concat "riece-ctcp-after-" response + "-response-hook")))) + (unless (riece-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)))))) - (run-hook-with-args-until-success - (intern (concat "riece-ctcp-after-" response "-response-hook")) - prefix (car targets) message)) + (riece-funcall-ignore-errors + (symbol-name function) + function prefix (car targets) message)) + (riece-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) @@ -166,23 +268,131 @@ elapsed)) "\n")))) -(defun riece-command-ctcp-version (user) +(defun riece-handle-ctcp-clientinfo-response (prefix target string) + (riece-insert-change + (list riece-dialogue-buffer riece-others-buffer) + (concat + (riece-concat-server-name + (format "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 "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 - (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 (target) + (interactive + (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 (target action) + (interactive + (list (if current-prefix-arg + (riece-completing-read-identity + "Channel/User: " + (riece-get-identities-on-server (riece-current-server-name))) + riece-current-channel) + (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 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-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))) + +(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) + (define-key riece-dialogue-mode-map "\C-ct" 'riece-command-ctcp-time) + (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) + (define-key riece-dialogue-mode-map "\C-ct" nil) + (setq riece-ctcp-enabled nil)) + (provide 'riece-ctcp) -;;; riece-ctcp.el ends here \ No newline at end of file +;;; riece-ctcp.el ends here