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-display)
30 (require 'riece-highlight)
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 (defun riece-ctcp-requires ()
53 (if (memq 'riece-highlight riece-addons)
56 (defun riece-ctcp-insinuate ()
57 (add-hook 'riece-privmsg-hook 'riece-handle-ctcp-request)
58 (add-hook 'riece-notice-hook 'riece-handle-ctcp-response)
59 (if (memq 'riece-highlight riece-addons)
60 (setq riece-dialogue-font-lock-keywords
61 (cons (list (concat "^" riece-time-prefix-regexp "\\("
62 (regexp-quote riece-ctcp-action-prefix)
64 1 riece-ctcp-action-face t t)
65 riece-dialogue-font-lock-keywords)))
66 (define-key riece-dialogue-mode-map "\C-cv" 'riece-command-ctcp-version)
67 (define-key riece-dialogue-mode-map "\C-cp" 'riece-command-ctcp-ping)
68 (define-key riece-dialogue-mode-map "\C-ca" 'riece-command-ctcp-action)
69 (define-key riece-dialogue-mode-map "\C-cc" 'riece-command-ctcp-clientinfo))
71 (defun riece-handle-ctcp-request (prefix string)
72 (when (and prefix string
73 (riece-prefix-nickname prefix))
74 (let* ((parameters (riece-split-parameters string))
75 (targets (split-string (car parameters) ","))
76 (message (nth 1 parameters)))
77 (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message)
78 (let ((request (downcase (match-string 1 message))))
79 (if (match-beginning 2)
80 (setq message (substring (match-string 2 message) 1)))
82 (intern (concat "riece-ctcp-" request "-request-hook")))
84 (intern-soft (concat "riece-handle-ctcp-" request
87 (intern (concat "riece-ctcp-after-" request
89 (unless (condition-case error
90 (run-hook-with-args-until-success
91 hook prefix (car targets) message)
94 (message "Error occurred in `%S': %S" hook error))
98 (funcall function prefix (car targets) message)
101 (message "Error occurred in `%S': %S"
103 (condition-case error
104 (run-hook-with-args-until-success
105 after-hook prefix (car targets) message)
108 (message "Error occurred in `%S': %S"
109 after-hook error)))))
112 (defun riece-handle-ctcp-version-request (prefix target string)
113 (let ((buffer (if (riece-channel-p target)
114 (riece-channel-buffer (riece-make-identity
115 target riece-server-name))))
116 (user (riece-prefix-nickname prefix)))
118 (format "NOTICE %s :\1VERSION %s\1\r\n" user (riece-extended-version)))
119 (riece-insert-change buffer (format "CTCP VERSION from %s\n" user))
121 (if (and riece-channel-buffer-mode
122 (not (eq buffer riece-channel-buffer)))
123 (list riece-dialogue-buffer riece-others-buffer)
124 riece-dialogue-buffer)
126 (riece-concat-server-name
127 (format "CTCP VERSION from %s (%s) to %s"
129 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
133 (defun riece-handle-ctcp-ping-request (prefix target string)
134 (let ((buffer (if (riece-channel-p target)
135 (riece-channel-buffer (riece-make-identity
136 target riece-server-name))))
137 (user (riece-prefix-nickname prefix)))
140 (format "NOTICE %s :\1PING %s\1\r\n" user string)
141 (format "NOTICE %s :\1PING\1\r\n" user string)))
142 (riece-insert-change buffer (format "CTCP PING from %s\n" user))
144 (if (and riece-channel-buffer-mode
145 (not (eq buffer riece-channel-buffer)))
146 (list riece-dialogue-buffer riece-others-buffer)
147 riece-dialogue-buffer)
149 (riece-concat-server-name
150 (format "CTCP PING from %s (%s) to %s"
152 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
156 (defun riece-handle-ctcp-clientinfo-request (prefix target string)
157 (let ((buffer (if (riece-channel-p target)
158 (riece-channel-buffer (riece-make-identity
159 target riece-server-name))))
160 (user (riece-prefix-nickname prefix)))
162 (format "NOTICE %s :\1CLIENTINFO %s\1\r\n"
167 (let ((case-fold-search t))
168 (if (and (fboundp atom)
170 "riece-handle-ctcp-\\(.+\\)-request"
173 (cons (match-string 1 (symbol-name atom))
175 (mapconcat #'upcase (append messages
176 riece-ctcp-additional-clientinfo)
178 (riece-insert-change buffer (format "CTCP CLIENTINFO from %s\n" user))
180 (if (and riece-channel-buffer-mode
181 (not (eq buffer riece-channel-buffer)))
182 (list riece-dialogue-buffer riece-others-buffer)
183 riece-dialogue-buffer)
185 (riece-concat-server-name
186 (format "CTCP CLIENTINFO from %s (%s) to %s"
188 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
192 (defun riece-handle-ctcp-action-request (prefix target string)
193 (let ((buffer (if (riece-channel-p target)
194 (riece-channel-buffer (riece-make-identity
195 target riece-server-name))))
196 (user (riece-prefix-nickname prefix)))
197 (riece-insert buffer (concat riece-ctcp-action-prefix user " " string
200 (if (and riece-channel-buffer-mode
201 (not (eq buffer riece-channel-buffer)))
202 (list riece-dialogue-buffer riece-others-buffer)
203 riece-dialogue-buffer)
204 (concat (riece-concat-server-name (concat riece-ctcp-action-prefix user
205 " " string)) "\n"))))
207 (defun riece-handle-ctcp-response (prefix string)
208 (when (and prefix string
209 (riece-prefix-nickname prefix))
210 (let* ((parameters (riece-split-parameters string))
211 (targets (split-string (car parameters) ","))
212 (message (nth 1 parameters)))
213 (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message)
214 (let ((response (downcase (match-string 1 message))))
215 (if (match-beginning 2)
216 (setq message (substring (match-string 2 message) 1)))
218 (intern (concat "riece-ctcp-" response "-response-hook")))
219 (function (intern-soft (concat "riece-handle-ctcp-"
220 response "-response")))
222 (intern (concat "riece-ctcp-after-" response
224 (unless (condition-case error
225 (run-hook-with-args-until-success
226 hook prefix (car targets) message)
229 (message "Error occurred in `%S': %S" hook error))
232 (condition-case error
233 (funcall function prefix (car targets) message)
236 (message "Error occurred in `%S': %S"
238 (condition-case error
239 (run-hook-with-args-until-success
240 after-hook prefix (car targets) message)
243 (message "Error occurred in `%S': %S"
244 after-hook error)))))
247 (defun riece-handle-ctcp-version-response (prefix target string)
249 (list riece-dialogue-buffer riece-others-buffer)
251 (riece-concat-server-name
252 (format "CTCP VERSION for %s (%s) = %s"
253 (riece-prefix-nickname prefix)
254 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
258 (defun riece-handle-ctcp-ping-response (prefix target string)
259 (let* ((now (current-time))
260 (elapsed (+ (* 65536 (- (car now) (car riece-ctcp-ping-time)))
261 (- (nth 1 now) (nth 1 riece-ctcp-ping-time)))))
263 (list riece-dialogue-buffer riece-others-buffer)
265 (riece-concat-server-name
266 (format "CTCP PING for %s (%s) = %d sec"
267 (riece-prefix-nickname prefix)
268 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
272 (defun riece-handle-ctcp-clientinfo-response (prefix target string)
274 (list riece-dialogue-buffer riece-others-buffer)
276 (riece-concat-server-name
277 (format "CTCP CLIENTINFO for %s (%s) = %s"
278 (riece-prefix-nickname prefix)
279 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
283 (defun riece-command-ctcp-version (target)
285 (list (riece-completing-read-identity
288 (mapcar (lambda (entry)
289 (riece-get-identities-on-server (car entry)))
290 riece-server-process-alist)))))
291 (riece-send-string (format "PRIVMSG %s :\1VERSION\1\r\n"
292 (riece-identity-prefix target))))
294 (defun riece-command-ctcp-ping (target)
296 (list (riece-completing-read-identity
299 (mapcar (lambda (entry)
300 (riece-get-identities-on-server (car entry)))
301 riece-server-process-alist)))))
302 (riece-send-string (format "PRIVMSG %s :\1PING\1\r\n"
303 (riece-identity-prefix target)))
304 (setq riece-ctcp-ping-time (current-time)))
306 (defun riece-command-ctcp-clientinfo (target)
308 (list (riece-completing-read-identity
311 (mapcar (lambda (entry)
312 (riece-get-identities-on-server (car entry)))
313 riece-server-process-alist)))))
314 (riece-send-string (format "PRIVMSG %s :\1CLIENTINFO\1\r\n"
315 (riece-identity-prefix target))))
317 (defun riece-command-ctcp-action (target action)
319 (list (if current-prefix-arg
320 (riece-completing-read-identity
323 (mapcar (lambda (entry)
324 (riece-get-identities-on-server (car entry)))
325 riece-server-process-alist)))
326 riece-current-channel)
327 (read-string "Action: ")))
328 (if (equal action "")
330 (riece-send-string (format "PRIVMSG %s :\1ACTION %s\1\r\n"
331 (riece-identity-prefix target)
333 (let ((buffer (riece-channel-buffer target)))
336 (concat riece-ctcp-action-prefix
337 (riece-identity-prefix (riece-current-nickname)) " " action "\n"))
339 (if (and riece-channel-buffer-mode
340 (not (eq buffer riece-channel-buffer)))
341 (list riece-dialogue-buffer riece-others-buffer)
342 riece-dialogue-buffer)
344 (riece-concat-server-name
345 (concat riece-ctcp-action-prefix
346 (riece-identity-prefix (riece-current-nickname)) " " action))
349 (provide 'riece-ctcp)
351 ;;; riece-ctcp.el ends here