1 ;;; riece-ctcp.el --- CTCP add-on
2 ;; Copyright (C) 1998-2003 Daiki Ueno
4 ;; Author: Daiki Ueno <ueno@unixuser.org>
6 ;; Keywords: IRC, riece
8 ;; This file is part of Riece.
10 ;; This program is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; This program is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
27 (require 'riece-version)
29 (require 'riece-display)
31 (defvar riece-ctcp-ping-time nil)
32 (defvar riece-ctcp-additional-clientinfo nil)
34 (defvar riece-dialogue-mode-map)
36 (defun riece-ctcp-insinuate ()
37 (add-hook 'riece-privmsg-hook 'riece-handle-ctcp-request)
38 (add-hook 'riece-notice-hook 'riece-handle-ctcp-response)
39 (define-key riece-dialogue-mode-map "\C-cv" 'riece-command-ctcp-version)
40 (define-key riece-dialogue-mode-map "\C-cp" 'riece-command-ctcp-ping)
41 (define-key riece-dialogue-mode-map "\C-ca" 'riece-command-ctcp-action)
42 (define-key riece-dialogue-mode-map "\C-cc" 'riece-command-ctcp-clientinfo))
44 (defun riece-handle-ctcp-request (prefix string)
45 (when (and prefix string
46 (riece-prefix-nickname prefix))
47 (let* ((parameters (riece-split-parameters string))
48 (targets (split-string (car parameters) ","))
49 (message (nth 1 parameters)))
50 (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message)
51 (let ((request (downcase (match-string 1 message))))
52 (if (match-beginning 2)
53 (setq message (substring (match-string 2 message) 1)))
55 (intern (concat "riece-ctcp-" request "-request-hook")))
57 (intern-soft (concat "riece-handle-ctcp-" request
60 (intern (concat "riece-ctcp-after-" request
62 (unless (condition-case error
63 (run-hook-with-args-until-success
64 hook prefix (car targets) message)
67 (message "Error occurred in `%S': %S" hook error))
71 (funcall function prefix (car targets) message)
74 (message "Error occurred in `%S': %S"
77 (run-hook-with-args-until-success
78 after-hook prefix (car targets) message)
81 (message "Error occurred in `%S': %S"
85 (defun riece-handle-ctcp-version-request (prefix target string)
86 (let ((buffer (if (riece-channel-p target)
87 (riece-channel-buffer-name
88 (riece-make-identity target riece-server-name))))
89 (user (riece-prefix-nickname prefix)))
91 (format "NOTICE %s :\1VERSION %s\1\r\n" user (riece-extended-version)))
92 (riece-insert-change buffer (format "CTCP VERSION from %s\n" user))
94 (if (and riece-channel-buffer-mode
95 (not (eq buffer riece-channel-buffer)))
96 (list riece-dialogue-buffer riece-others-buffer)
97 riece-dialogue-buffer)
99 (riece-concat-server-name
100 (format "CTCP VERSION from %s (%s) to %s"
102 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
106 (defun riece-handle-ctcp-ping-request (prefix target string)
107 (let ((buffer (if (riece-channel-p target)
108 (riece-channel-buffer-name
109 (riece-make-identity target riece-server-name))))
110 (user (riece-prefix-nickname prefix)))
113 (format "NOTICE %s :\1PING %s\1\r\n" user string)
114 (format "NOTICE %s :\1PING\1\r\n" user string)))
115 (riece-insert-change buffer (format "CTCP PING from %s\n" user))
117 (if (and riece-channel-buffer-mode
118 (not (eq buffer riece-channel-buffer)))
119 (list riece-dialogue-buffer riece-others-buffer)
120 riece-dialogue-buffer)
122 (riece-concat-server-name
123 (format "CTCP PING from %s (%s) to %s"
125 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
129 (defun riece-handle-ctcp-clientinfo-request (prefix target string)
130 (let ((buffer (if (riece-channel-p target)
131 (riece-channel-buffer-name
132 (riece-make-identity target riece-server-name))))
133 (user (riece-prefix-nickname prefix)))
135 (format "NOTICE %s :\1CLIENTINFO %s\1\r\n"
140 (let ((case-fold-search t))
141 (if (and (fboundp atom)
143 "riece-handle-ctcp-\\(.+\\)-request"
146 (cons (match-string 1 (symbol-name atom))
148 (mapconcat #'upcase (append messages
149 riece-ctcp-additional-clientinfo)
151 (riece-insert-change buffer (format "CTCP CLIENTINFO from %s\n" user))
153 (if (and riece-channel-buffer-mode
154 (not (eq buffer riece-channel-buffer)))
155 (list riece-dialogue-buffer riece-others-buffer)
156 riece-dialogue-buffer)
158 (riece-concat-server-name
159 (format "CTCP CLIENTINFO from %s (%s) to %s"
161 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
165 (defun riece-handle-ctcp-action-request (prefix target string)
166 (let ((buffer (if (riece-channel-p target)
167 (riece-channel-buffer-name
168 (riece-make-identity target riece-server-name))))
169 (user (riece-prefix-nickname prefix)))
170 (riece-insert-change buffer (concat user " " string "\n"))
172 (if (and riece-channel-buffer-mode
173 (not (eq buffer riece-channel-buffer)))
174 (list riece-dialogue-buffer riece-others-buffer)
175 riece-dialogue-buffer)
176 (concat (riece-concat-server-name (concat user " " string)) "\n"))))
178 (defun riece-handle-ctcp-response (prefix string)
179 (when (and prefix string
180 (riece-prefix-nickname prefix))
181 (let* ((parameters (riece-split-parameters string))
182 (targets (split-string (car parameters) ","))
183 (message (nth 1 parameters)))
184 (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message)
185 (let ((response (downcase (match-string 1 message))))
186 (if (match-beginning 2)
187 (setq message (substring (match-string 2 message) 1)))
189 (intern (concat "riece-ctcp-" response "-response-hook")))
190 (function (intern-soft (concat "riece-handle-ctcp-"
191 response "-response")))
193 (intern (concat "riece-ctcp-after-" response
195 (unless (condition-case error
196 (run-hook-with-args-until-success
197 hook prefix (car targets) message)
200 (message "Error occurred in `%S': %S" hook error))
203 (condition-case error
204 (funcall function prefix (car targets) message)
207 (message "Error occurred in `%S': %S"
209 (condition-case error
210 (run-hook-with-args-until-success
211 after-hook prefix (car targets) message)
214 (message "Error occurred in `%S': %S"
215 after-hook error)))))
218 (defun riece-handle-ctcp-version-response (prefix target string)
220 (list riece-dialogue-buffer riece-others-buffer)
222 (riece-concat-server-name
223 (format "CTCP VERSION for %s (%s) = %s"
224 (riece-prefix-nickname prefix)
225 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
229 (defun riece-handle-ctcp-ping-response (prefix target string)
230 (let* ((now (current-time))
231 (elapsed (+ (* 65536 (- (car now) (car riece-ctcp-ping-time)))
232 (- (nth 1 now) (nth 1 riece-ctcp-ping-time)))))
234 (list riece-dialogue-buffer riece-others-buffer)
236 (riece-concat-server-name
237 (format "CTCP PING for %s (%s) = %d sec"
238 (riece-prefix-nickname prefix)
239 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
243 (defun riece-handle-ctcp-clientinfo-response (prefix target string)
245 (list riece-dialogue-buffer riece-others-buffer)
247 (riece-concat-server-name
248 (format "CTCP CLIENTINFO for %s (%s) = %s"
249 (riece-prefix-nickname prefix)
250 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
254 (defun riece-command-ctcp-version (user)
256 (let ((completion-ignore-case t))
257 (list (completing-read
259 (mapcar #'list (riece-get-users-on-server))))))
260 (riece-send-string (format "PRIVMSG %s :\1VERSION\1\r\n" user)))
262 (defun riece-command-ctcp-ping (user)
264 (let ((completion-ignore-case t))
265 (list (completing-read
267 (mapcar #'list (riece-get-users-on-server))))))
268 (riece-send-string (format "PRIVMSG %s :\1PING\1\r\n" user))
269 (setq riece-ctcp-ping-time (current-time)))
271 (defun riece-command-ctcp-clientinfo (user)
273 (let ((completion-ignore-case t))
274 (list (completing-read
276 (mapcar #'list (riece-get-users-on-server))))))
277 (riece-send-string (format "PRIVMSG %s :\1CLIENTINFO\1\r\n" user)))
279 (defun riece-command-ctcp-action (channel action)
281 (list (if current-prefix-arg
284 (mapcar #'list riece-current-channels))
285 riece-current-channel)
286 (read-string "Action: ")))
287 (if (equal action "")
289 (riece-send-string (format "PRIVMSG %s :\1ACTION %s\1\r\n"
290 (riece-identity-prefix channel)
292 (let ((buffer (riece-channel-buffer-name
293 (riece-make-identity channel riece-server-name))))
296 (concat (riece-identity-prefix (riece-current-nickname)) " " action "\n"))
298 (if (and riece-channel-buffer-mode
299 (not (eq buffer riece-channel-buffer)))
300 (list riece-dialogue-buffer riece-others-buffer)
301 riece-dialogue-buffer)
303 (riece-concat-server-name
304 (concat (riece-identity-prefix (riece-current-nickname)) " " action))
307 (provide 'riece-ctcp)
309 ;;; riece-ctcp.el ends here