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-highlight)
30 (require 'riece-display)
32 (defface riece-ctcp-action-face
35 (:foreground "PaleGreen" :italic t))
38 (:foreground "ForestGreen" :italic t))
41 "Face used for displaying \"*** Action:\" line"
42 :group 'riece-highlight-faces)
43 (defvar riece-ctcp-action-face 'riece-ctcp-action-face)
45 (defconst riece-ctcp-action-prefix "*** Action: ")
47 (defvar riece-ctcp-ping-time nil)
48 (defvar riece-ctcp-additional-clientinfo nil)
50 (defvar riece-dialogue-mode-map)
52 (defvar riece-ctcp-enabled nil)
54 (defconst riece-ctcp-description
55 "CTCP (Client To Client Protocol) support")
57 (defun riece-handle-ctcp-request (prefix string)
58 (when (and riece-ctcp-enabled prefix string
59 (riece-prefix-nickname prefix))
60 (let* ((parameters (riece-split-parameters string))
61 (targets (split-string (car parameters) ","))
62 (message (nth 1 parameters)))
63 (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message)
64 (let ((request (downcase (match-string 1 message))))
65 (if (match-beginning 2)
66 (setq message (substring (match-string 2 message) 1)))
68 (intern (concat "riece-ctcp-" request "-request-hook")))
70 (intern-soft (concat "riece-handle-ctcp-" request
73 (intern (concat "riece-ctcp-after-" request
75 (unless (condition-case error
76 (run-hook-with-args-until-success
77 hook prefix (car targets) message)
80 (message "Error in `%S': %S" hook error))
84 (funcall function prefix (car targets) message)
87 (message "Error in `%S': %S"
90 (run-hook-with-args-until-success
91 after-hook prefix (car targets) message)
94 (message "Error in `%S': %S"
98 (defun riece-handle-ctcp-version-request (prefix target string)
99 (let* ((target-identity (riece-make-identity target riece-server-name))
100 (buffer (if (riece-channel-p target)
101 (riece-channel-buffer target-identity)))
102 (user (riece-prefix-nickname prefix)))
104 (format "NOTICE %s :\1VERSION %s\1\r\n" user (riece-extended-version)))
105 (riece-insert-change buffer (format "CTCP VERSION from %s\n" user))
107 (if (and riece-channel-buffer-mode
108 (not (eq buffer riece-channel-buffer)))
109 (list riece-dialogue-buffer riece-others-buffer)
110 riece-dialogue-buffer)
112 (riece-concat-server-name
113 (format "CTCP VERSION from %s (%s) to %s"
115 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
116 (riece-format-identity target-identity t)))
119 (defun riece-handle-ctcp-ping-request (prefix target string)
120 (let* ((target-identity (riece-make-identity target riece-server-name))
121 (buffer (if (riece-channel-p target)
122 (riece-channel-buffer target-identity)))
123 (user (riece-prefix-nickname prefix)))
126 (format "NOTICE %s :\1PING %s\1\r\n" user string)
127 (format "NOTICE %s :\1PING\1\r\n" user string)))
128 (riece-insert-change buffer (format "CTCP PING from %s\n" user))
130 (if (and riece-channel-buffer-mode
131 (not (eq buffer riece-channel-buffer)))
132 (list riece-dialogue-buffer riece-others-buffer)
133 riece-dialogue-buffer)
135 (riece-concat-server-name
136 (format "CTCP PING from %s (%s) to %s"
138 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
139 (riece-format-identity target-identity t)))
142 (defun riece-handle-ctcp-clientinfo-request (prefix target string)
143 (let* ((target-identity (riece-make-identity target riece-server-name))
144 (buffer (if (riece-channel-p target)
145 (riece-channel-buffer target-identity)))
146 (user (riece-prefix-nickname prefix)))
148 (format "NOTICE %s :\1CLIENTINFO %s\1\r\n"
153 (let ((case-fold-search t))
154 (if (and (fboundp atom)
156 "riece-handle-ctcp-\\(.+\\)-request"
159 (cons (match-string 1 (symbol-name atom))
161 (mapconcat #'upcase (append messages
162 riece-ctcp-additional-clientinfo)
164 (riece-insert-change buffer (format "CTCP CLIENTINFO from %s\n" user))
166 (if (and riece-channel-buffer-mode
167 (not (eq buffer riece-channel-buffer)))
168 (list riece-dialogue-buffer riece-others-buffer)
169 riece-dialogue-buffer)
171 (riece-concat-server-name
172 (format "CTCP CLIENTINFO from %s (%s) to %s"
174 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
175 (riece-format-identity target-identity t)))
178 (defun riece-handle-ctcp-action-request (prefix target string)
179 (let ((buffer (if (riece-channel-p target)
180 (riece-channel-buffer (riece-make-identity
181 target riece-server-name))))
182 (user (riece-prefix-nickname prefix)))
183 (riece-insert buffer (concat riece-ctcp-action-prefix user " " string
186 (if (and riece-channel-buffer-mode
187 (not (eq buffer riece-channel-buffer)))
188 (list riece-dialogue-buffer riece-others-buffer)
189 riece-dialogue-buffer)
190 (concat (riece-concat-server-name (concat riece-ctcp-action-prefix user
191 " " string)) "\n"))))
193 (defun riece-handle-ctcp-response (prefix string)
194 (when (and riece-ctcp-enabled prefix string
195 (riece-prefix-nickname prefix))
196 (let* ((parameters (riece-split-parameters string))
197 (targets (split-string (car parameters) ","))
198 (message (nth 1 parameters)))
199 (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message)
200 (let ((response (downcase (match-string 1 message))))
201 (if (match-beginning 2)
202 (setq message (substring (match-string 2 message) 1)))
204 (intern (concat "riece-ctcp-" response "-response-hook")))
205 (function (intern-soft (concat "riece-handle-ctcp-"
206 response "-response")))
208 (intern (concat "riece-ctcp-after-" response
210 (unless (condition-case error
211 (run-hook-with-args-until-success
212 hook prefix (car targets) message)
215 (message "Error in `%S': %S" hook error))
218 (condition-case error
219 (funcall function prefix (car targets) message)
222 (message "Error in `%S': %S"
224 (condition-case error
225 (run-hook-with-args-until-success
226 after-hook prefix (car targets) message)
229 (message "Error in `%S': %S"
230 after-hook error)))))
233 (defun riece-handle-ctcp-version-response (prefix target string)
235 (list riece-dialogue-buffer riece-others-buffer)
237 (riece-concat-server-name
238 (format "CTCP VERSION for %s (%s) = %s"
239 (riece-prefix-nickname prefix)
240 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
244 (defun riece-handle-ctcp-ping-response (prefix target string)
245 (let* ((now (current-time))
246 (elapsed (+ (* 65536 (- (car now) (car riece-ctcp-ping-time)))
247 (- (nth 1 now) (nth 1 riece-ctcp-ping-time)))))
249 (list riece-dialogue-buffer riece-others-buffer)
251 (riece-concat-server-name
252 (format "CTCP PING for %s (%s) = %d sec"
253 (riece-prefix-nickname prefix)
254 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
258 (defun riece-handle-ctcp-clientinfo-response (prefix target string)
260 (list riece-dialogue-buffer riece-others-buffer)
262 (riece-concat-server-name
263 (format "CTCP CLIENTINFO for %s (%s) = %s"
264 (riece-prefix-nickname prefix)
265 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
269 (defun riece-command-ctcp-version (target)
271 (list (riece-completing-read-identity
273 (riece-get-identities-on-server (riece-current-server-name)))))
274 (riece-send-string (format "PRIVMSG %s :\1VERSION\1\r\n"
275 (riece-identity-prefix target))))
277 (defun riece-command-ctcp-ping (target)
279 (list (riece-completing-read-identity
281 (riece-get-identities-on-server (riece-current-server-name)))))
282 (riece-send-string (format "PRIVMSG %s :\1PING\1\r\n"
283 (riece-identity-prefix target)))
284 (setq riece-ctcp-ping-time (current-time)))
286 (defun riece-command-ctcp-clientinfo (target)
288 (list (riece-completing-read-identity
290 (riece-get-identities-on-server (riece-current-server-name)))))
291 (riece-send-string (format "PRIVMSG %s :\1CLIENTINFO\1\r\n"
292 (riece-identity-prefix target))))
294 (defun riece-command-ctcp-action (target action)
296 (list (if current-prefix-arg
297 (riece-completing-read-identity
299 (riece-get-identities-on-server (riece-current-server-name)))
300 riece-current-channel)
303 (setq message (buffer-substring (point)
304 (progn (end-of-line) (point))))
305 (if (equal message "")
306 (read-string "Action: ")
307 (prog1 (read-from-minibuffer "Action: " (cons message 0))
308 (let ((next-line-add-newlines t))
310 (if (equal action "")
312 (riece-send-string (format "PRIVMSG %s :\1ACTION %s\1\r\n"
313 (riece-identity-prefix target)
315 (let ((buffer (riece-channel-buffer target)))
318 (concat riece-ctcp-action-prefix
319 (riece-identity-prefix (riece-current-nickname)) " " action "\n"))
321 (if (and riece-channel-buffer-mode
322 (not (eq buffer riece-channel-buffer)))
323 (list riece-dialogue-buffer riece-others-buffer)
324 riece-dialogue-buffer)
326 (riece-with-server-buffer (riece-identity-server target)
327 (riece-concat-server-name
328 (concat riece-ctcp-action-prefix
329 (riece-identity-prefix (riece-current-nickname)) " " action
330 " (in " (riece-format-identity target t) ")")))
333 (defun riece-ctcp-requires ()
334 (if (memq 'riece-highlight riece-addons)
337 (defun riece-ctcp-insinuate ()
338 (add-hook 'riece-privmsg-hook 'riece-handle-ctcp-request)
339 (add-hook 'riece-notice-hook 'riece-handle-ctcp-response)
340 (if (memq 'riece-highlight riece-addons)
341 (setq riece-dialogue-font-lock-keywords
342 (cons (list (concat "^" riece-time-prefix-regexp "\\("
343 (regexp-quote riece-ctcp-action-prefix)
345 1 riece-ctcp-action-face t t)
346 riece-dialogue-font-lock-keywords))))
348 (defun riece-ctcp-enable ()
349 (define-key riece-dialogue-mode-map "\C-cv" 'riece-command-ctcp-version)
350 (define-key riece-dialogue-mode-map "\C-cp" 'riece-command-ctcp-ping)
351 (define-key riece-dialogue-mode-map "\C-ca" 'riece-command-ctcp-action)
352 (define-key riece-dialogue-mode-map "\C-cc" 'riece-command-ctcp-clientinfo)
353 (setq riece-ctcp-enabled t))
355 (defun riece-ctcp-disable ()
356 (define-key riece-dialogue-mode-map "\C-cv" nil)
357 (define-key riece-dialogue-mode-map "\C-cp" nil)
358 (define-key riece-dialogue-mode-map "\C-ca" nil)
359 (define-key riece-dialogue-mode-map "\C-cc" nil)
360 (setq riece-ctcp-enabled nil))
362 (provide 'riece-ctcp)
364 ;;; riece-ctcp.el ends here