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)
30 (defvar riece-ctcp-ping-time nil)
31 (defvar riece-ctcp-additional-clientinfo nil)
33 (defvar riece-dialogue-mode-map)
35 (defun riece-ctcp-insinuate ()
36 (add-hook 'riece-privmsg-hook 'riece-handle-ctcp-request)
37 (add-hook 'riece-notice-hook 'riece-handle-ctcp-response)
38 (define-key riece-dialogue-mode-map "\C-cv" 'riece-command-ctcp-version)
39 (define-key riece-dialogue-mode-map "\C-cp" 'riece-command-ctcp-ping)
40 (define-key riece-dialogue-mode-map "\C-ca" 'riece-command-ctcp-action)
41 (define-key riece-dialogue-mode-map "\C-cc" 'riece-command-ctcp-clientinfo))
43 (defun riece-handle-ctcp-request (prefix string)
44 (when (and prefix string
45 (riece-prefix-nickname prefix))
46 (let* ((parameters (riece-split-parameters string))
47 (targets (split-string (car parameters) ","))
48 (message (nth 1 parameters)))
49 (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message)
50 (let ((request (downcase (match-string 1 message))))
51 (if (match-beginning 2)
52 (setq message (substring (match-string 2 message) 1)))
54 (intern (concat "riece-ctcp-" request "-request-hook")))
56 (intern-soft (concat "riece-handle-ctcp-" request
59 (intern (concat "riece-ctcp-after-" request
61 (unless (condition-case error
62 (run-hook-with-args-until-success
63 hook prefix (car targets) message)
66 (message "Error occurred in `%S': %S" hook error))
70 (funcall function prefix (car targets) message)
73 (message "Error occurred in `%S': %S"
76 (run-hook-with-args-until-success
77 after-hook prefix (car targets) message)
80 (message "Error occurred in `%S': %S"
84 (defun riece-handle-ctcp-version-request (prefix target string)
85 (let ((buffer (if (riece-channel-p target)
86 (riece-channel-buffer-name
87 (riece-make-identity target riece-server-name))))
88 (user (riece-prefix-nickname prefix)))
90 (format "NOTICE %s :\1VERSION %s\1\r\n" user (riece-extended-version)))
91 (riece-insert-change buffer (format "CTCP VERSION from %s\n" user))
93 (if (and riece-channel-buffer-mode
94 (not (eq buffer riece-channel-buffer)))
95 (list riece-dialogue-buffer riece-others-buffer)
96 riece-dialogue-buffer)
98 (riece-concat-server-name
99 (format "CTCP VERSION from %s (%s) to %s"
101 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
105 (defun riece-handle-ctcp-ping-request (prefix target string)
106 (let ((buffer (if (riece-channel-p target)
107 (riece-channel-buffer-name
108 (riece-make-identity target riece-server-name))))
109 (user (riece-prefix-nickname prefix)))
112 (format "NOTICE %s :\1PING %s\1\r\n" user string)
113 (format "NOTICE %s :\1PING\1\r\n" user string)))
114 (riece-insert-change buffer (format "CTCP PING from %s\n" user))
116 (if (and riece-channel-buffer-mode
117 (not (eq buffer riece-channel-buffer)))
118 (list riece-dialogue-buffer riece-others-buffer)
119 riece-dialogue-buffer)
121 (riece-concat-server-name
122 (format "CTCP PING from %s (%s) to %s"
124 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
128 (defun riece-handle-ctcp-clientinfo-request (prefix target string)
129 (let ((buffer (if (riece-channel-p target)
130 (riece-channel-buffer-name
131 (riece-make-identity target riece-server-name))))
132 (user (riece-prefix-nickname prefix)))
134 (format "NOTICE %s :\1CLIENTINFO %s\1\r\n"
139 (let ((case-fold-search t))
140 (if (and (fboundp atom)
142 "riece-handle-ctcp-\\(.+\\)-request"
145 (cons (match-string 1 (symbol-name atom))
147 (mapconcat #'upcase (append messages
148 riece-ctcp-additional-clientinfo)
150 (riece-insert-change buffer (format "CTCP CLIENTINFO from %s\n" user))
152 (if (and riece-channel-buffer-mode
153 (not (eq buffer riece-channel-buffer)))
154 (list riece-dialogue-buffer riece-others-buffer)
155 riece-dialogue-buffer)
157 (riece-concat-server-name
158 (format "CTCP CLIENTINFO from %s (%s) to %s"
160 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
164 (defun riece-handle-ctcp-action-request (prefix target string)
165 (let ((buffer (if (riece-channel-p target)
166 (riece-channel-buffer-name
167 (riece-make-identity target riece-server-name))))
168 (user (riece-prefix-nickname prefix)))
169 (riece-insert-change buffer (concat user " " string "\n"))
171 (if (and riece-channel-buffer-mode
172 (not (eq buffer riece-channel-buffer)))
173 (list riece-dialogue-buffer riece-others-buffer)
174 riece-dialogue-buffer)
175 (concat (riece-concat-server-name (concat user " " string)) "\n"))))
177 (defun riece-handle-ctcp-response (prefix string)
178 (when (and prefix string
179 (riece-prefix-nickname prefix))
180 (let* ((parameters (riece-split-parameters string))
181 (targets (split-string (car parameters) ","))
182 (message (nth 1 parameters)))
183 (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message)
184 (let ((response (downcase (match-string 1 message))))
185 (if (match-beginning 2)
186 (setq message (substring (match-string 2 message) 1)))
188 (intern (concat "riece-ctcp-" response "-response-hook")))
189 (function (intern-soft (concat "riece-handle-ctcp-"
190 response "-response")))
192 (intern (concat "riece-ctcp-after-" response
194 (unless (condition-case error
195 (run-hook-with-args-until-success
196 hook prefix (car targets) message)
199 (message "Error occurred in `%S': %S" hook error))
202 (condition-case error
203 (funcall function prefix (car targets) message)
206 (message "Error occurred in `%S': %S"
208 (condition-case error
209 (run-hook-with-args-until-success
210 after-hook prefix (car targets) message)
213 (message "Error occurred in `%S': %S"
214 after-hook error)))))
217 (defun riece-handle-ctcp-version-response (prefix target string)
219 (list riece-dialogue-buffer riece-others-buffer)
221 (riece-concat-server-name
222 (format "CTCP VERSION for %s (%s) = %s"
223 (riece-prefix-nickname prefix)
224 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
228 (defun riece-handle-ctcp-ping-response (prefix target string)
229 (let* ((now (current-time))
230 (elapsed (+ (* 65536 (- (car now) (car riece-ctcp-ping-time)))
231 (- (nth 1 now) (nth 1 riece-ctcp-ping-time)))))
233 (list riece-dialogue-buffer riece-others-buffer)
235 (riece-concat-server-name
236 (format "CTCP PING for %s (%s) = %d sec"
237 (riece-prefix-nickname prefix)
238 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
242 (defun riece-handle-ctcp-clientinfo-response (prefix target string)
244 (list riece-dialogue-buffer riece-others-buffer)
246 (riece-concat-server-name
247 (format "CTCP CLIENTINFO for %s (%s) = %s"
248 (riece-prefix-nickname prefix)
249 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
253 (defun riece-command-ctcp-version (user)
255 (let ((completion-ignore-case t))
256 (list (completing-read
258 (mapcar #'list (riece-get-users-on-server))))))
259 (riece-send-string (format "PRIVMSG %s :\1VERSION\1\r\n" user)))
261 (defun riece-command-ctcp-ping (user)
263 (let ((completion-ignore-case t))
264 (list (completing-read
266 (mapcar #'list (riece-get-users-on-server))))))
267 (riece-send-string (format "PRIVMSG %s :\1PING\1\r\n" user))
268 (setq riece-ctcp-ping-time (current-time)))
270 (defun riece-command-ctcp-clientinfo (user)
272 (let ((completion-ignore-case t))
273 (list (completing-read
275 (mapcar #'list (riece-get-users-on-server))))))
276 (riece-send-string (format "PRIVMSG %s :\1CLIENTINFO\1\r\n" user)))
278 (defun riece-command-ctcp-action (channel action)
280 (list (if current-prefix-arg
283 (mapcar #'list riece-current-channels))
284 riece-current-channel)
285 (read-string "Action: ")))
286 (if (equal action "")
288 (riece-send-string (format "PRIVMSG %s :\1ACTION %s\1\r\n"
289 (riece-identity-prefix channel)
291 (let ((buffer (riece-channel-buffer-name
292 (riece-make-identity channel riece-server-name))))
295 (concat (riece-identity-prefix (riece-current-nickname)) " " action "\n"))
297 (if (and riece-channel-buffer-mode
298 (not (eq buffer riece-channel-buffer)))
299 (list riece-dialogue-buffer riece-others-buffer)
300 riece-dialogue-buffer)
302 (riece-concat-server-name
303 (concat (riece-identity-prefix (riece-current-nickname)) " " action))
306 (provide 'riece-ctcp)
308 ;;; riece-ctcp.el ends here