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 (require 'riece-message)
39 (defface riece-ctcp-action-face
42 (:foreground "PaleGreen" :italic t))
45 (:foreground "ForestGreen" :italic t))
48 "Face used for displaying \"*** Action:\" line"
49 :group 'riece-highlight-faces)
50 (defvar riece-ctcp-action-face 'riece-ctcp-action-face)
52 (defconst riece-ctcp-action-prefix "*** Action: ")
54 (defvar riece-ctcp-ping-time nil)
55 (defvar riece-ctcp-additional-clientinfo nil)
57 (defvar riece-dialogue-mode-map)
59 (defconst riece-ctcp-description
60 "CTCP (Client To Client Protocol) support.")
62 (defun riece-handle-ctcp-request (prefix string)
63 (when (and (get 'riece-ctcp 'riece-addon-enabled) prefix string
64 (riece-prefix-nickname prefix))
65 (let* ((parameters (riece-split-parameters string))
66 (targets (split-string (car parameters) ","))
67 (message (nth 1 parameters)))
68 (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message)
69 (let ((request (downcase (match-string 1 message))))
70 (if (match-beginning 2)
71 (setq message (substring (match-string 2 message) 1)))
73 (intern (concat "riece-ctcp-" request "-request-hook")))
75 (intern-soft (concat "riece-handle-ctcp-" request
78 (intern (concat "riece-ctcp-after-" request
80 (unless (riece-funcall-ignore-errors
82 #'run-hook-with-args-until-success
83 hook prefix (car targets) message)
85 (riece-funcall-ignore-errors (symbol-name function)
86 function prefix (car targets)
88 (riece-funcall-ignore-errors (symbol-name after-hook)
89 #'run-hook-with-args-until-success
90 after-hook prefix (car targets)
94 (defun riece-handle-ctcp-version-request (prefix target string)
95 (let* ((target-identity (riece-make-identity target riece-server-name))
96 (buffer (if (riece-channel-p target)
97 (riece-channel-buffer target-identity)))
98 (user (riece-prefix-nickname prefix)))
100 (format "NOTICE %s :\1VERSION %s\1\r\n" user (riece-extended-version)))
101 (riece-insert-change buffer (format "CTCP VERSION from %s\n" user))
103 (if (and riece-channel-buffer-mode
104 (not (eq buffer riece-channel-buffer)))
105 (list riece-dialogue-buffer riece-others-buffer)
106 riece-dialogue-buffer)
108 (riece-concat-server-name
109 (format (riece-mcat "CTCP VERSION from %s (%s) to %s")
111 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
112 (riece-format-identity target-identity t)))
115 (defun riece-handle-ctcp-ping-request (prefix target string)
116 (let* ((target-identity (riece-make-identity target riece-server-name))
117 (buffer (if (riece-channel-p target)
118 (riece-channel-buffer target-identity)))
119 (user (riece-prefix-nickname prefix)))
122 (format "NOTICE %s :\1PING %s\1\r\n" user string)
123 (format "NOTICE %s :\1PING\1\r\n" user)))
124 (riece-insert-change buffer (format "CTCP PING from %s\n" user))
126 (if (and riece-channel-buffer-mode
127 (not (eq buffer riece-channel-buffer)))
128 (list riece-dialogue-buffer riece-others-buffer)
129 riece-dialogue-buffer)
131 (riece-concat-server-name
132 (format (riece-mcat "CTCP PING from %s (%s) to %s")
134 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
135 (riece-format-identity target-identity t)))
138 (defun riece-handle-ctcp-clientinfo-request (prefix target string)
139 (let* ((target-identity (riece-make-identity target riece-server-name))
140 (buffer (if (riece-channel-p target)
141 (riece-channel-buffer target-identity)))
142 (user (riece-prefix-nickname prefix)))
144 (format "NOTICE %s :\1CLIENTINFO %s\1\r\n"
149 (let ((case-fold-search t))
150 (if (and (fboundp atom)
152 "riece-handle-ctcp-\\(.+\\)-request"
155 (cons (match-string 1 (symbol-name atom))
157 (mapconcat #'upcase (append messages
158 riece-ctcp-additional-clientinfo)
160 (riece-insert-change buffer (format "CTCP CLIENTINFO from %s\n" user))
162 (if (and riece-channel-buffer-mode
163 (not (eq buffer riece-channel-buffer)))
164 (list riece-dialogue-buffer riece-others-buffer)
165 riece-dialogue-buffer)
167 (riece-concat-server-name
168 (format (riece-mcat "CTCP CLIENTINFO from %s (%s) to %s")
170 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
171 (riece-format-identity target-identity t)))
174 (defun riece-ctcp-action-format-message (message &optional global)
175 (riece-with-server-buffer (riece-identity-server
176 (riece-message-speaker message))
179 (riece-concat-server-name
180 (concat riece-ctcp-action-prefix
181 (riece-format-identity (riece-message-target message) t) ": "
182 (riece-identity-prefix (riece-message-speaker message)) " "
183 (riece-message-text message)))
184 (concat riece-ctcp-action-prefix
185 (riece-identity-prefix (riece-message-speaker message)) " "
186 (riece-message-text message)))
189 (defun riece-handle-ctcp-action-request (prefix target string)
190 (let ((buffer (if (riece-channel-p target)
191 (riece-channel-buffer (riece-make-identity
192 target riece-server-name))))
193 (user (riece-prefix-nickname prefix)))
194 (riece-display-message
195 (riece-make-message (riece-make-identity user
197 (riece-make-identity target
201 (riece-identity-equal-no-server
202 user riece-real-nickname)))))
204 (defun riece-handle-ctcp-time-request (prefix target string)
205 (let* ((target-identity (riece-make-identity target riece-server-name))
206 (buffer (if (riece-channel-p target)
207 (riece-channel-buffer target-identity)))
208 (user (riece-prefix-nickname prefix))
209 (time (format-time-string "%c")))
211 (format "NOTICE %s :\1TIME %s\1\r\n" user time))
212 (riece-insert-change buffer (format (riece-mcat "CTCP TIME from %s\n")
215 (if (and riece-channel-buffer-mode
216 (not (eq buffer riece-channel-buffer)))
217 (list riece-dialogue-buffer riece-others-buffer)
218 riece-dialogue-buffer)
220 (riece-concat-server-name
221 (format (riece-mcat "CTCP TIME from %s (%s) to %s")
223 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
224 (riece-format-identity target-identity t)))
227 (defun riece-handle-ctcp-response (prefix string)
228 (when (and (get 'riece-ctcp 'riece-addon-enabled) prefix string
229 (riece-prefix-nickname prefix))
230 (let* ((parameters (riece-split-parameters string))
231 (targets (split-string (car parameters) ","))
232 (message (nth 1 parameters)))
233 (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message)
234 (let ((response (downcase (match-string 1 message))))
235 (if (match-beginning 2)
236 (setq message (substring (match-string 2 message) 1)))
238 (intern (concat "riece-ctcp-" response "-response-hook")))
239 (function (intern-soft (concat "riece-handle-ctcp-"
240 response "-response")))
242 (intern (concat "riece-ctcp-after-" response
244 (unless (riece-funcall-ignore-errors
246 #'run-hook-with-args-until-success
247 hook prefix (car targets) message)
249 (riece-funcall-ignore-errors
250 (symbol-name function)
251 function prefix (car targets) message))
252 (riece-funcall-ignore-errors (symbol-name after-hook)
253 #'run-hook-with-args-until-success
254 after-hook prefix (car targets)
258 (defun riece-handle-ctcp-version-response (prefix target string)
260 (list riece-dialogue-buffer riece-others-buffer)
262 (riece-concat-server-name
263 (format (riece-mcat "CTCP VERSION for %s (%s) = %s")
264 (riece-prefix-nickname prefix)
265 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
269 (defun riece-handle-ctcp-ping-response (prefix target string)
270 (let* ((now (current-time))
271 (elapsed (+ (* 65536 (- (car now) (car riece-ctcp-ping-time)))
272 (- (nth 1 now) (nth 1 riece-ctcp-ping-time)))))
274 (list riece-dialogue-buffer riece-others-buffer)
276 (riece-concat-server-name
277 (format (riece-mcat "CTCP PING for %s (%s) = %d sec")
278 (riece-prefix-nickname prefix)
279 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
283 (defun riece-handle-ctcp-clientinfo-response (prefix target string)
285 (list riece-dialogue-buffer riece-others-buffer)
287 (riece-concat-server-name
288 (format (riece-mcat "CTCP CLIENTINFO for %s (%s) = %s")
289 (riece-prefix-nickname prefix)
290 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
294 (defun riece-handle-ctcp-time-response (prefix target string)
296 (list riece-dialogue-buffer riece-others-buffer)
298 (riece-concat-server-name
299 (format (riece-mcat "CTCP TIME for %s (%s) = %s")
300 (riece-prefix-nickname prefix)
301 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
305 (defun riece-command-ctcp-version (target)
307 (list (riece-completing-read-identity
308 (riece-mcat "Channel/User: ")
309 (riece-get-identities-on-server (riece-current-server-name)))))
310 (riece-send-string (format "PRIVMSG %s :\1VERSION\1\r\n"
311 (riece-identity-prefix target))))
313 (defun riece-command-ctcp-ping (target)
315 (list (riece-completing-read-identity
316 (riece-mcat "Channel/User: ")
317 (riece-get-identities-on-server (riece-current-server-name)))))
318 (riece-send-string (format "PRIVMSG %s :\1PING\1\r\n"
319 (riece-identity-prefix target)))
320 (setq riece-ctcp-ping-time (current-time)))
322 (defun riece-command-ctcp-clientinfo (target)
324 (list (riece-completing-read-identity
325 (riece-mcat "Channel/User: ")
326 (riece-get-identities-on-server (riece-current-server-name)))))
327 (riece-send-string (format "PRIVMSG %s :\1CLIENTINFO\1\r\n"
328 (riece-identity-prefix target))))
330 (defun riece-command-ctcp-action (target action)
332 (list (if current-prefix-arg
333 (riece-completing-read-identity
334 (riece-mcat "Channel/User: ")
335 (riece-get-identities-on-server (riece-current-server-name)))
336 riece-current-channel)
339 (setq message (buffer-substring (point)
340 (progn (end-of-line) (point))))
341 (if (equal message "")
342 (read-string (riece-mcat "Action: "))
343 (prog1 (read-from-minibuffer (riece-mcat "Action: ")
345 (let ((next-line-add-newlines t))
347 (if (equal action "")
349 (riece-send-string (format "PRIVMSG %s :\1ACTION %s\1\r\n"
350 (riece-identity-prefix target)
352 (riece-display-message
353 (riece-make-message (riece-current-nickname) target action 'action t)))
355 (defun riece-command-ctcp-time (target)
357 (list (riece-completing-read-identity
358 (riece-mcat "Channel/User: ")
359 (riece-get-identities-on-server (riece-current-server-name)))))
360 (riece-send-string (format "PRIVMSG %s :\1TIME\1\r\n"
361 (riece-identity-prefix target))))
363 (defun riece-ctcp-requires ()
364 (if (memq 'riece-highlight riece-addons)
367 (defvar riece-ctcp-dialogue-font-lock-keywords
368 (list (concat "^" riece-time-prefix-regexp "\\("
369 (regexp-quote riece-ctcp-action-prefix)
371 1 riece-ctcp-action-face t t))
373 (defun riece-ctcp-insinuate ()
374 (add-hook 'riece-privmsg-hook 'riece-handle-ctcp-request)
375 (add-hook 'riece-notice-hook 'riece-handle-ctcp-response)
376 (if (memq 'riece-highlight riece-addons)
377 (setq riece-dialogue-font-lock-keywords
378 (cons riece-ctcp-dialogue-font-lock-keywords
379 riece-dialogue-font-lock-keywords)))
380 (unless (assq 'action riece-message-format-function-alist)
381 (setq riece-message-format-function-alist
382 (cons (cons 'action #'riece-ctcp-action-format-message)
383 riece-message-format-function-alist))))
385 (defun riece-ctcp-uninstall ()
386 (remove-hook 'riece-privmsg-hook 'riece-handle-ctcp-request)
387 (remove-hook 'riece-notice-hook 'riece-handle-ctcp-response)
388 (setq riece-dialogue-font-lock-keywords
389 (delq riece-ctcp-dialogue-font-lock-keywords
390 riece-dialogue-font-lock-keywords)))
392 (defun riece-ctcp-enable ()
393 (define-key riece-dialogue-mode-map "\C-cv" 'riece-command-ctcp-version)
394 (define-key riece-dialogue-mode-map "\C-cp" 'riece-command-ctcp-ping)
395 (define-key riece-dialogue-mode-map "\C-ca" 'riece-command-ctcp-action)
396 (define-key riece-dialogue-mode-map "\C-cc" 'riece-command-ctcp-clientinfo)
397 (define-key riece-dialogue-mode-map "\C-ct" 'riece-command-ctcp-time))
399 (defun riece-ctcp-disable ()
400 (define-key riece-dialogue-mode-map "\C-cv" nil)
401 (define-key riece-dialogue-mode-map "\C-cp" nil)
402 (define-key riece-dialogue-mode-map "\C-ca" nil)
403 (define-key riece-dialogue-mode-map "\C-cc" nil)
404 (define-key riece-dialogue-mode-map "\C-ct" nil))
406 (provide 'riece-ctcp)
408 ;;; riece-ctcp.el ends here