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)
38 (defface riece-ctcp-action-face
41 (:foreground "PaleGreen" :italic t))
44 (:foreground "ForestGreen" :italic t))
47 "Face used for displaying \"*** Action:\" line"
48 :group 'riece-highlight-faces)
49 (defvar riece-ctcp-action-face 'riece-ctcp-action-face)
51 (defconst riece-ctcp-action-prefix "*** Action: ")
53 (defvar riece-ctcp-ping-time nil)
54 (defvar riece-ctcp-additional-clientinfo nil)
56 (defvar riece-dialogue-mode-map)
58 (defconst riece-ctcp-description
59 "CTCP (Client To Client Protocol) support.")
61 (defun riece-handle-ctcp-request (prefix string)
62 (when (and (get 'riece-ctcp 'riece-addon-enabled) prefix string
63 (riece-prefix-nickname prefix))
64 (let* ((parameters (riece-split-parameters string))
65 (targets (split-string (car parameters) ","))
66 (message (nth 1 parameters)))
67 (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message)
68 (let ((request (downcase (match-string 1 message))))
69 (if (match-beginning 2)
70 (setq message (substring (match-string 2 message) 1)))
72 (intern (concat "riece-ctcp-" request "-request-hook")))
74 (intern-soft (concat "riece-handle-ctcp-" request
77 (intern (concat "riece-ctcp-after-" request
79 (unless (riece-funcall-ignore-errors
81 #'run-hook-with-args-until-success
82 hook prefix (car targets) message)
84 (riece-funcall-ignore-errors (symbol-name function)
85 function prefix (car targets)
87 (riece-funcall-ignore-errors (symbol-name after-hook)
88 #'run-hook-with-args-until-success
89 after-hook prefix (car targets)
93 (defun riece-handle-ctcp-version-request (prefix target string)
94 (let* ((target-identity (riece-make-identity target riece-server-name))
95 (buffer (if (riece-channel-p target)
96 (riece-channel-buffer target-identity)))
97 (user (riece-prefix-nickname prefix)))
99 (format "NOTICE %s :\1VERSION %s\1\r\n" user (riece-extended-version)))
100 (riece-insert-change buffer (format "CTCP VERSION from %s\n" user))
102 (if (and riece-channel-buffer-mode
103 (not (eq buffer riece-channel-buffer)))
104 (list riece-dialogue-buffer riece-others-buffer)
105 riece-dialogue-buffer)
107 (riece-concat-server-name
108 (format (riece-mcat "CTCP VERSION from %s (%s) to %s")
110 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
111 (riece-format-identity target-identity t)))
114 (defun riece-handle-ctcp-ping-request (prefix target string)
115 (let* ((target-identity (riece-make-identity target riece-server-name))
116 (buffer (if (riece-channel-p target)
117 (riece-channel-buffer target-identity)))
118 (user (riece-prefix-nickname prefix)))
121 (format "NOTICE %s :\1PING %s\1\r\n" user string)
122 (format "NOTICE %s :\1PING\1\r\n" user)))
123 (riece-insert-change buffer (format "CTCP PING from %s\n" user))
125 (if (and riece-channel-buffer-mode
126 (not (eq buffer riece-channel-buffer)))
127 (list riece-dialogue-buffer riece-others-buffer)
128 riece-dialogue-buffer)
130 (riece-concat-server-name
131 (format (riece-mcat "CTCP PING from %s (%s) to %s")
133 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
134 (riece-format-identity target-identity t)))
137 (defun riece-handle-ctcp-clientinfo-request (prefix target string)
138 (let* ((target-identity (riece-make-identity target riece-server-name))
139 (buffer (if (riece-channel-p target)
140 (riece-channel-buffer target-identity)))
141 (user (riece-prefix-nickname prefix)))
143 (format "NOTICE %s :\1CLIENTINFO %s\1\r\n"
148 (let ((case-fold-search t))
149 (if (and (fboundp atom)
151 "riece-handle-ctcp-\\(.+\\)-request"
154 (cons (match-string 1 (symbol-name atom))
156 (mapconcat #'upcase (append messages
157 riece-ctcp-additional-clientinfo)
159 (riece-insert-change buffer (format "CTCP CLIENTINFO from %s\n" user))
161 (if (and riece-channel-buffer-mode
162 (not (eq buffer riece-channel-buffer)))
163 (list riece-dialogue-buffer riece-others-buffer)
164 riece-dialogue-buffer)
166 (riece-concat-server-name
167 (format (riece-mcat "CTCP CLIENTINFO from %s (%s) to %s")
169 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
170 (riece-format-identity target-identity t)))
173 (defun riece-ctcp-action-format-message (message &optional global)
174 (riece-with-server-buffer (riece-identity-server
175 (riece-message-speaker message))
178 (riece-concat-server-name
179 (concat riece-ctcp-action-prefix
180 (riece-format-identity (riece-message-target message) t) ": "
181 (riece-identity-prefix (riece-message-speaker message)) " "
182 (riece-message-text message)))
183 (concat riece-ctcp-action-prefix
184 (riece-identity-prefix (riece-message-speaker message)) " "
185 (riece-message-text message)))
188 (defun riece-handle-ctcp-action-request (prefix target string)
189 (let ((buffer (if (riece-channel-p target)
190 (riece-channel-buffer (riece-make-identity
191 target riece-server-name))))
192 (user (riece-prefix-nickname prefix)))
193 (riece-display-message
194 (riece-make-message (riece-make-identity user
196 (riece-make-identity target
200 (riece-identity-equal-no-server
201 user riece-real-nickname)))))
203 (defun riece-handle-ctcp-time-request (prefix target string)
204 (let* ((target-identity (riece-make-identity target riece-server-name))
205 (buffer (if (riece-channel-p target)
206 (riece-channel-buffer target-identity)))
207 (user (riece-prefix-nickname prefix))
208 (time (format-time-string "%c")))
210 (format "NOTICE %s :\1TIME %s\1\r\n" user time))
211 (riece-insert-change buffer (format (riece-mcat "CTCP TIME from %s\n")
214 (if (and riece-channel-buffer-mode
215 (not (eq buffer riece-channel-buffer)))
216 (list riece-dialogue-buffer riece-others-buffer)
217 riece-dialogue-buffer)
219 (riece-concat-server-name
220 (format (riece-mcat "CTCP TIME from %s (%s) to %s")
222 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
223 (riece-format-identity target-identity t)))
226 (defun riece-handle-ctcp-response (prefix string)
227 (when (and (get 'riece-ctcp 'riece-addon-enabled) prefix string
228 (riece-prefix-nickname prefix))
229 (let* ((parameters (riece-split-parameters string))
230 (targets (split-string (car parameters) ","))
231 (message (nth 1 parameters)))
232 (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message)
233 (let ((response (downcase (match-string 1 message))))
234 (if (match-beginning 2)
235 (setq message (substring (match-string 2 message) 1)))
237 (intern (concat "riece-ctcp-" response "-response-hook")))
238 (function (intern-soft (concat "riece-handle-ctcp-"
239 response "-response")))
241 (intern (concat "riece-ctcp-after-" response
243 (unless (riece-funcall-ignore-errors
245 #'run-hook-with-args-until-success
246 hook prefix (car targets) message)
248 (riece-funcall-ignore-errors
249 (symbol-name function)
250 function prefix (car targets) message))
251 (riece-funcall-ignore-errors (symbol-name after-hook)
252 #'run-hook-with-args-until-success
253 after-hook prefix (car targets)
257 (defun riece-handle-ctcp-version-response (prefix target string)
259 (list riece-dialogue-buffer riece-others-buffer)
261 (riece-concat-server-name
262 (format (riece-mcat "CTCP VERSION for %s (%s) = %s")
263 (riece-prefix-nickname prefix)
264 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
268 (defun riece-handle-ctcp-ping-response (prefix target string)
269 (let* ((now (current-time))
270 (elapsed (+ (* 65536 (- (car now) (car riece-ctcp-ping-time)))
271 (- (nth 1 now) (nth 1 riece-ctcp-ping-time)))))
273 (list riece-dialogue-buffer riece-others-buffer)
275 (riece-concat-server-name
276 (format (riece-mcat "CTCP PING for %s (%s) = %d sec")
277 (riece-prefix-nickname prefix)
278 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
282 (defun riece-handle-ctcp-clientinfo-response (prefix target string)
284 (list riece-dialogue-buffer riece-others-buffer)
286 (riece-concat-server-name
287 (format (riece-mcat "CTCP CLIENTINFO for %s (%s) = %s")
288 (riece-prefix-nickname prefix)
289 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
293 (defun riece-handle-ctcp-time-response (prefix target string)
295 (list riece-dialogue-buffer riece-others-buffer)
297 (riece-concat-server-name
298 (format (riece-mcat "CTCP TIME for %s (%s) = %s")
299 (riece-prefix-nickname prefix)
300 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
304 (defun riece-command-ctcp-version (target)
306 (list (riece-completing-read-identity
307 (riece-mcat "Channel/User: ")
308 (riece-get-identities-on-server (riece-current-server-name)))))
309 (riece-send-string (format "PRIVMSG %s :\1VERSION\1\r\n"
310 (riece-identity-prefix target))))
312 (defun riece-command-ctcp-ping (target)
314 (list (riece-completing-read-identity
315 (riece-mcat "Channel/User: ")
316 (riece-get-identities-on-server (riece-current-server-name)))))
317 (riece-send-string (format "PRIVMSG %s :\1PING\1\r\n"
318 (riece-identity-prefix target)))
319 (setq riece-ctcp-ping-time (current-time)))
321 (defun riece-command-ctcp-clientinfo (target)
323 (list (riece-completing-read-identity
324 (riece-mcat "Channel/User: ")
325 (riece-get-identities-on-server (riece-current-server-name)))))
326 (riece-send-string (format "PRIVMSG %s :\1CLIENTINFO\1\r\n"
327 (riece-identity-prefix target))))
329 (defun riece-command-ctcp-action (target action)
331 (list (if current-prefix-arg
332 (riece-completing-read-identity
333 (riece-mcat "Channel/User: ")
334 (riece-get-identities-on-server (riece-current-server-name)))
335 riece-current-channel)
338 (setq message (buffer-substring (point)
339 (progn (end-of-line) (point))))
340 (if (equal message "")
341 (read-string (riece-mcat "Action: "))
342 (prog1 (read-from-minibuffer (riece-mcat "Action: ")
344 (let ((next-line-add-newlines t))
346 (if (equal action "")
348 (riece-send-string (format "PRIVMSG %s :\1ACTION %s\1\r\n"
349 (riece-identity-prefix target)
351 (riece-display-message
352 (riece-make-message (riece-current-nickname) target action 'action t)))
354 (defun riece-command-ctcp-time (target)
356 (list (riece-completing-read-identity
357 (riece-mcat "Channel/User: ")
358 (riece-get-identities-on-server (riece-current-server-name)))))
359 (riece-send-string (format "PRIVMSG %s :\1TIME\1\r\n"
360 (riece-identity-prefix target))))
362 (defun riece-ctcp-requires ()
363 (if (memq 'riece-highlight riece-addons)
366 (defvar riece-ctcp-dialogue-font-lock-keywords
367 (list (concat "^" riece-time-prefix-regexp "\\("
368 (regexp-quote riece-ctcp-action-prefix)
370 1 riece-ctcp-action-face t t))
372 (defun riece-ctcp-insinuate ()
373 (add-hook 'riece-privmsg-hook 'riece-handle-ctcp-request)
374 (add-hook 'riece-notice-hook 'riece-handle-ctcp-response)
375 (if (memq 'riece-highlight riece-addons)
376 (setq riece-dialogue-font-lock-keywords
377 (cons riece-ctcp-dialogue-font-lock-keywords
378 riece-dialogue-font-lock-keywords)))
379 (unless (assq 'action riece-message-format-function-alist)
380 (setq riece-message-format-function-alist
381 (cons (cons 'action #'riece-ctcp-action-format-message)
382 riece-message-format-function-alist))))
384 (defun riece-ctcp-uninstall ()
385 (remove-hook 'riece-privmsg-hook 'riece-handle-ctcp-request)
386 (remove-hook 'riece-notice-hook 'riece-handle-ctcp-response)
387 (setq riece-dialogue-font-lock-keywords
388 (delq riece-ctcp-dialogue-font-lock-keywords
389 riece-dialogue-font-lock-keywords)))
391 (defun riece-ctcp-enable ()
392 (define-key riece-dialogue-mode-map "\C-cv" 'riece-command-ctcp-version)
393 (define-key riece-dialogue-mode-map "\C-cp" 'riece-command-ctcp-ping)
394 (define-key riece-dialogue-mode-map "\C-ca" 'riece-command-ctcp-action)
395 (define-key riece-dialogue-mode-map "\C-cc" 'riece-command-ctcp-clientinfo)
396 (define-key riece-dialogue-mode-map "\C-ct" 'riece-command-ctcp-time))
398 (defun riece-ctcp-disable ()
399 (define-key riece-dialogue-mode-map "\C-cv" nil)
400 (define-key riece-dialogue-mode-map "\C-cp" nil)
401 (define-key riece-dialogue-mode-map "\C-ca" nil)
402 (define-key riece-dialogue-mode-map "\C-cc" nil)
403 (define-key riece-dialogue-mode-map "\C-ct" nil))
405 (provide 'riece-ctcp)
407 ;;; riece-ctcp.el ends here