(require 'riece-version)
(require 'riece-misc)
+(require 'riece-display)
(defvar riece-ctcp-ping-time nil)
+(defvar riece-ctcp-additional-clientinfo nil)
(defvar riece-dialogue-mode-map)
(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-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))
(defun riece-handle-ctcp-request (prefix string)
(when (and 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 (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))
(if function
(condition-case error
(funcall function prefix (car targets) message)
(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))
+ (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)))))
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))))
+ (riece-channel-buffer (riece-make-identity
+ target riece-server-name))))
(user (riece-prefix-nickname prefix)))
(riece-send-string
(format "NOTICE %s :\1VERSION %s\1\r\n" user (riece-extended-version)))
(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))))
+ (riece-channel-buffer (riece-make-identity
+ target riece-server-name))))
(user (riece-prefix-nickname prefix)))
(riece-send-string
(if string
target))
"\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)))
+ (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))
+ target))
+ "\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-change buffer (concat user " " string "\n"))
+ (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 user " " string)) "\n"))))
+
(defun riece-handle-ctcp-response (prefix string)
(when (and 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 (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))
(if function
(condition-case error
(funcall function prefix (car targets) message)
(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))
+ (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)))))
t)))))
(defun riece-handle-ctcp-version-response (prefix target string)
elapsed))
"\n"))))
+(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-ctcp-completing-read-identity ()
+ (riece-completing-read-identity
+ "Channel/User: "
+ (let ((server-name (riece-current-server-name)))
+ (append (mapcar
+ (lambda (user)
+ (riece-make-identity user server-name))
+ (riece-get-users-on-server))
+ riece-current-channels))))
+
(defun riece-command-ctcp-version (user)
(interactive
- (let ((completion-ignore-case t))
- (list (completing-read
- "Channel/User: "
- (mapcar #'list (riece-get-users-on-server))))))
+ (list (riece-ctcp-completing-read-identity)))
(riece-send-string (format "PRIVMSG %s :\1VERSION\1\r\n" user)))
(defun riece-command-ctcp-ping (user)
(interactive
- (let ((completion-ignore-case t))
- (list (completing-read
- "Channel/User: "
- (mapcar #'list (riece-get-users-on-server))))))
+ (list (riece-ctcp-completing-read-identity)))
(riece-send-string (format "PRIVMSG %s :\1PING\1\r\n" user))
(setq riece-ctcp-ping-time (current-time)))
+(defun riece-command-ctcp-clientinfo (user)
+ (interactive
+ (list (riece-ctcp-completing-read-identity)))
+ (riece-send-string (format "PRIVMSG %s :\1CLIENTINFO\1\r\n" user)))
+
+(defun riece-command-ctcp-action (channel action)
+ (interactive
+ (list (if current-prefix-arg
+ (riece-ctcp-completing-read-identity)
+ riece-current-channel)
+ (read-string "Action: ")))
+ (if (equal action "")
+ (error "No action"))
+ (riece-send-string (format "PRIVMSG %s :\1ACTION %s\1\r\n"
+ (riece-identity-prefix channel)
+ action))
+ (let ((buffer (riece-channel-buffer channel)))
+ (riece-insert-change
+ buffer
+ (concat (riece-identity-prefix (riece-current-nickname)) " " action "\n"))
+ (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-identity-prefix (riece-current-nickname)) " " action))
+ "\n"))))
+
(provide 'riece-ctcp)
-;;; riece-ctcp.el ends here
\ No newline at end of file
+;;; riece-ctcp.el ends here
projects / riece / blobdiff