1 ;;; riece-ctcp.el --- CTCP (Client To Client Protocol) support
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., 51 Franklin Street, Fifth Floor,
23 ;; Boston, MA 02110-1301, USA.
27 ;; NOTE: This is an add-on module for Riece.
31 (require 'riece-version)
33 (require 'riece-highlight)
34 (require 'riece-display)
35 (require 'riece-debug)
37 (defface riece-ctcp-action-face
40 (:foreground "PaleGreen" :italic t))
43 (:foreground "ForestGreen" :italic t))
46 "Face used for displaying \"*** Action:\" line"
47 :group 'riece-highlight-faces)
48 (defvar riece-ctcp-action-face 'riece-ctcp-action-face)
50 (defconst riece-ctcp-action-prefix "*** Action: ")
52 (defvar riece-ctcp-ping-time nil)
53 (defvar riece-ctcp-additional-clientinfo nil)
55 (defvar riece-dialogue-mode-map)
57 (defconst riece-ctcp-description
58 "CTCP (Client To Client Protocol) support.")
60 (defun riece-handle-ctcp-request (prefix string)
61 (when (and (get 'riece-ctcp 'riece-addon-enabled) prefix string
62 (riece-prefix-nickname prefix))
63 (let* ((parameters (riece-split-parameters string))
64 (targets (split-string (car parameters) ","))
65 (message (nth 1 parameters)))
66 (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message)
67 (let ((request (downcase (match-string 1 message))))
68 (if (match-beginning 2)
69 (setq message (substring (match-string 2 message) 1)))
71 (intern (concat "riece-ctcp-" request "-request-hook")))
73 (intern-soft (concat "riece-handle-ctcp-" request
76 (intern (concat "riece-ctcp-after-" request
78 (unless (riece-funcall-ignore-errors
80 #'run-hook-with-args-until-success
81 hook prefix (car targets) message)
83 (riece-funcall-ignore-errors (symbol-name function)
84 function prefix (car targets)
86 (riece-funcall-ignore-errors (symbol-name after-hook)
87 #'run-hook-with-args-until-success
88 after-hook prefix (car targets)
92 (defun riece-handle-ctcp-version-request (prefix target string)
93 (let* ((target-identity (riece-make-identity target riece-server-name))
94 (buffer (if (riece-channel-p target)
95 (riece-channel-buffer target-identity)))
96 (user (riece-prefix-nickname prefix)))
98 (format "NOTICE %s :\1VERSION %s\1\r\n" user (riece-extended-version)))
99 (riece-insert-change buffer (format "CTCP VERSION from %s\n" user))
101 (if (and riece-channel-buffer-mode
102 (not (eq buffer riece-channel-buffer)))
103 (list riece-dialogue-buffer riece-others-buffer)
104 riece-dialogue-buffer)
106 (riece-concat-server-name
107 (format "CTCP VERSION from %s (%s) to %s"
109 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
110 (riece-format-identity target-identity t)))
113 (defun riece-handle-ctcp-ping-request (prefix target string)
114 (let* ((target-identity (riece-make-identity target riece-server-name))
115 (buffer (if (riece-channel-p target)
116 (riece-channel-buffer target-identity)))
117 (user (riece-prefix-nickname prefix)))
120 (format "NOTICE %s :\1PING %s\1\r\n" user string)
121 (format "NOTICE %s :\1PING\1\r\n" user string)))
122 (riece-insert-change buffer (format "CTCP PING from %s\n" user))
124 (if (and riece-channel-buffer-mode
125 (not (eq buffer riece-channel-buffer)))
126 (list riece-dialogue-buffer riece-others-buffer)
127 riece-dialogue-buffer)
129 (riece-concat-server-name
130 (format "CTCP PING from %s (%s) to %s"
132 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
133 (riece-format-identity target-identity t)))
136 (defun riece-handle-ctcp-clientinfo-request (prefix target string)
137 (let* ((target-identity (riece-make-identity target riece-server-name))
138 (buffer (if (riece-channel-p target)
139 (riece-channel-buffer target-identity)))
140 (user (riece-prefix-nickname prefix)))
142 (format "NOTICE %s :\1CLIENTINFO %s\1\r\n"
147 (let ((case-fold-search t))
148 (if (and (fboundp atom)
150 "riece-handle-ctcp-\\(.+\\)-request"
153 (cons (match-string 1 (symbol-name atom))
155 (mapconcat #'upcase (append messages
156 riece-ctcp-additional-clientinfo)
158 (riece-insert-change buffer (format "CTCP CLIENTINFO from %s\n" user))
160 (if (and riece-channel-buffer-mode
161 (not (eq buffer riece-channel-buffer)))
162 (list riece-dialogue-buffer riece-others-buffer)
163 riece-dialogue-buffer)
165 (riece-concat-server-name
166 (format "CTCP CLIENTINFO from %s (%s) to %s"
168 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
169 (riece-format-identity target-identity t)))
172 (defun riece-handle-ctcp-action-request (prefix target string)
173 (let ((buffer (if (riece-channel-p target)
174 (riece-channel-buffer (riece-make-identity
175 target riece-server-name))))
176 (user (riece-prefix-nickname prefix)))
177 (riece-insert buffer (concat riece-ctcp-action-prefix
178 (riece-format-identity
179 (riece-make-identity user riece-server-name)
184 (if (and riece-channel-buffer-mode
185 (not (eq buffer riece-channel-buffer)))
186 (list riece-dialogue-buffer riece-others-buffer)
187 riece-dialogue-buffer)
188 (concat (riece-concat-server-name
189 (concat riece-ctcp-action-prefix
190 (riece-format-identity
191 (riece-make-identity target riece-server-name)
194 (riece-format-identity
195 (riece-make-identity user riece-server-name)
197 " " string)) "\n"))))
199 (defun riece-handle-ctcp-time-request (prefix target string)
200 (let* ((target-identity (riece-make-identity target riece-server-name))
201 (buffer (if (riece-channel-p target)
202 (riece-channel-buffer target-identity)))
203 (user (riece-prefix-nickname prefix))
204 (time (format-time-string "%c")))
206 (format "NOTICE %s :\1TIME %s\1\r\n" user time))
207 (riece-insert-change buffer (format "CTCP TIME from %s\n" user))
209 (if (and riece-channel-buffer-mode
210 (not (eq buffer riece-channel-buffer)))
211 (list riece-dialogue-buffer riece-others-buffer)
212 riece-dialogue-buffer)
214 (riece-concat-server-name
215 (format "CTCP TIME from %s (%s) to %s"
217 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
218 (riece-format-identity target-identity t)))
221 (defun riece-handle-ctcp-response (prefix string)
222 (when (and (get 'riece-ctcp 'riece-addon-enabled) prefix string
223 (riece-prefix-nickname prefix))
224 (let* ((parameters (riece-split-parameters string))
225 (targets (split-string (car parameters) ","))
226 (message (nth 1 parameters)))
227 (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message)
228 (let ((response (downcase (match-string 1 message))))
229 (if (match-beginning 2)
230 (setq message (substring (match-string 2 message) 1)))
232 (intern (concat "riece-ctcp-" response "-response-hook")))
233 (function (intern-soft (concat "riece-handle-ctcp-"
234 response "-response")))
236 (intern (concat "riece-ctcp-after-" response
238 (unless (riece-funcall-ignore-errors
240 #'run-hook-with-args-until-success
241 hook prefix (car targets) message)
243 (riece-funcall-ignore-errors
244 (symbol-name function)
245 function prefix (car targets) message))
246 (riece-funcall-ignore-errors (symbol-name after-hook)
247 #'run-hook-with-args-until-success
248 after-hook prefix (car targets)
252 (defun riece-handle-ctcp-version-response (prefix target string)
254 (list riece-dialogue-buffer riece-others-buffer)
256 (riece-concat-server-name
257 (format "CTCP VERSION for %s (%s) = %s"
258 (riece-prefix-nickname prefix)
259 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
263 (defun riece-handle-ctcp-ping-response (prefix target string)
264 (let* ((now (current-time))
265 (elapsed (+ (* 65536 (- (car now) (car riece-ctcp-ping-time)))
266 (- (nth 1 now) (nth 1 riece-ctcp-ping-time)))))
268 (list riece-dialogue-buffer riece-others-buffer)
270 (riece-concat-server-name
271 (format "CTCP PING for %s (%s) = %d sec"
272 (riece-prefix-nickname prefix)
273 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
277 (defun riece-handle-ctcp-clientinfo-response (prefix target string)
279 (list riece-dialogue-buffer riece-others-buffer)
281 (riece-concat-server-name
282 (format "CTCP CLIENTINFO for %s (%s) = %s"
283 (riece-prefix-nickname prefix)
284 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
288 (defun riece-handle-ctcp-time-response (prefix target string)
290 (list riece-dialogue-buffer riece-others-buffer)
292 (riece-concat-server-name
293 (format "CTCP TIME for %s (%s) = %s"
294 (riece-prefix-nickname prefix)
295 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
299 (defun riece-command-ctcp-version (target)
301 (list (riece-completing-read-identity
303 (riece-get-identities-on-server (riece-current-server-name)))))
304 (riece-send-string (format "PRIVMSG %s :\1VERSION\1\r\n"
305 (riece-identity-prefix target))))
307 (defun riece-command-ctcp-ping (target)
309 (list (riece-completing-read-identity
311 (riece-get-identities-on-server (riece-current-server-name)))))
312 (riece-send-string (format "PRIVMSG %s :\1PING\1\r\n"
313 (riece-identity-prefix target)))
314 (setq riece-ctcp-ping-time (current-time)))
316 (defun riece-command-ctcp-clientinfo (target)
318 (list (riece-completing-read-identity
320 (riece-get-identities-on-server (riece-current-server-name)))))
321 (riece-send-string (format "PRIVMSG %s :\1CLIENTINFO\1\r\n"
322 (riece-identity-prefix target))))
324 (defun riece-command-ctcp-action (target action)
326 (list (if current-prefix-arg
327 (riece-completing-read-identity
329 (riece-get-identities-on-server (riece-current-server-name)))
330 riece-current-channel)
333 (setq message (buffer-substring (point)
334 (progn (end-of-line) (point))))
335 (if (equal message "")
336 (read-string "Action: ")
337 (prog1 (read-from-minibuffer "Action: " (cons message 0))
338 (let ((next-line-add-newlines t))
340 (if (equal action "")
342 (riece-send-string (format "PRIVMSG %s :\1ACTION %s\1\r\n"
343 (riece-identity-prefix target)
345 (let ((buffer (riece-channel-buffer target)))
348 (concat riece-ctcp-action-prefix
349 (riece-identity-prefix (riece-current-nickname)) " " action "\n"))
351 (if (and riece-channel-buffer-mode
352 (not (eq buffer riece-channel-buffer)))
353 (list riece-dialogue-buffer riece-others-buffer)
354 riece-dialogue-buffer)
356 (riece-with-server-buffer (riece-identity-server target)
357 (riece-concat-server-name
358 (concat riece-ctcp-action-prefix
359 (riece-format-identity target t) ": "
360 (riece-identity-prefix (riece-current-nickname)) " " action)))
363 (defun riece-command-ctcp-time (target)
365 (list (riece-completing-read-identity
367 (riece-get-identities-on-server (riece-current-server-name)))))
368 (riece-send-string (format "PRIVMSG %s :\1TIME\1\r\n"
369 (riece-identity-prefix target))))
371 (defun riece-ctcp-requires ()
372 (if (memq 'riece-highlight riece-addons)
375 (defvar riece-ctcp-dialogue-font-lock-keywords
376 (list (concat "^" riece-time-prefix-regexp "\\("
377 (regexp-quote riece-ctcp-action-prefix)
379 1 riece-ctcp-action-face t t))
381 (defun riece-ctcp-insinuate ()
382 (add-hook 'riece-privmsg-hook 'riece-handle-ctcp-request)
383 (add-hook 'riece-notice-hook 'riece-handle-ctcp-response)
384 (if (memq 'riece-highlight riece-addons)
385 (setq riece-dialogue-font-lock-keywords
386 (cons riece-ctcp-dialogue-font-lock-keywords
387 riece-dialogue-font-lock-keywords))))
389 (defun riece-ctcp-uninstall ()
390 (remove-hook 'riece-privmsg-hook 'riece-handle-ctcp-request)
391 (remove-hook 'riece-notice-hook 'riece-handle-ctcp-response)
392 (setq riece-dialogue-font-lock-keywords
393 (delq riece-ctcp-dialogue-font-lock-keywords
394 riece-dialogue-font-lock-keywords)))
396 (defun riece-ctcp-enable ()
397 (define-key riece-dialogue-mode-map "\C-cv" 'riece-command-ctcp-version)
398 (define-key riece-dialogue-mode-map "\C-cp" 'riece-command-ctcp-ping)
399 (define-key riece-dialogue-mode-map "\C-ca" 'riece-command-ctcp-action)
400 (define-key riece-dialogue-mode-map "\C-cc" 'riece-command-ctcp-clientinfo)
401 (define-key riece-dialogue-mode-map "\C-ct" 'riece-command-ctcp-time))
403 (defun riece-ctcp-disable ()
404 (define-key riece-dialogue-mode-map "\C-cv" nil)
405 (define-key riece-dialogue-mode-map "\C-cp" nil)
406 (define-key riece-dialogue-mode-map "\C-ca" nil)
407 (define-key riece-dialogue-mode-map "\C-cc" nil)
408 (define-key riece-dialogue-mode-map "\C-ct" nil))
410 (provide 'riece-ctcp)
412 ;;; riece-ctcp.el ends here