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)
31 (defface riece-ctcp-action-face
34 (:foreground "PaleGreen" :italic t))
37 (:foreground "ForestGreen" :italic t))
40 "Face used for displaying \"*** Action:\" line"
41 :group 'riece-highlight-faces)
42 (defvar riece-ctcp-action-face 'riece-ctcp-action-face)
44 (defconst riece-ctcp-action-prefix "*** Action: ")
46 (defvar riece-ctcp-ping-time nil)
47 (defvar riece-ctcp-additional-clientinfo nil)
49 (defvar riece-dialogue-mode-map)
51 (defun riece-ctcp-requires ()
52 (if (memq 'riece-highlight riece-addons)
55 (defun riece-ctcp-insinuate ()
56 (add-hook 'riece-privmsg-hook 'riece-handle-ctcp-request)
57 (add-hook 'riece-notice-hook 'riece-handle-ctcp-response)
58 (if (memq 'riece-highlight riece-addons)
59 (setq riece-dialogue-font-lock-keywords
60 (cons (list (concat "^" riece-time-prefix-regexp "\\("
61 (regexp-quote riece-ctcp-action-prefix)
63 1 riece-ctcp-action-face t t)
64 riece-dialogue-font-lock-keywords)))
65 (define-key riece-dialogue-mode-map "\C-cv" 'riece-command-ctcp-version)
66 (define-key riece-dialogue-mode-map "\C-cp" 'riece-command-ctcp-ping)
67 (define-key riece-dialogue-mode-map "\C-ca" 'riece-command-ctcp-action)
68 (define-key riece-dialogue-mode-map "\C-cc" 'riece-command-ctcp-clientinfo))
70 (defun riece-handle-ctcp-request (prefix string)
71 (when (and prefix string
72 (riece-prefix-nickname prefix))
73 (let* ((parameters (riece-split-parameters string))
74 (targets (split-string (car parameters) ","))
75 (message (nth 1 parameters)))
76 (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message)
77 (let ((request (downcase (match-string 1 message))))
78 (if (match-beginning 2)
79 (setq message (substring (match-string 2 message) 1)))
81 (intern (concat "riece-ctcp-" request "-request-hook")))
83 (intern-soft (concat "riece-handle-ctcp-" request
86 (intern (concat "riece-ctcp-after-" request
88 (unless (condition-case error
89 (run-hook-with-args-until-success
90 hook prefix (car targets) message)
93 (message "Error in `%S': %S" hook error))
97 (funcall function prefix (car targets) message)
100 (message "Error in `%S': %S"
102 (condition-case error
103 (run-hook-with-args-until-success
104 after-hook prefix (car targets) message)
107 (message "Error in `%S': %S"
108 after-hook error)))))
111 (defun riece-handle-ctcp-version-request (prefix target string)
112 (let* ((target-identity (riece-make-identity target riece-server-name))
113 (buffer (if (riece-channel-p target)
114 (riece-channel-buffer target-identity)))
115 (user (riece-prefix-nickname prefix)))
117 (format "NOTICE %s :\1VERSION %s\1\r\n" user (riece-extended-version)))
118 (riece-insert-change buffer (format "CTCP VERSION from %s\n" user))
120 (if (and riece-channel-buffer-mode
121 (not (eq buffer riece-channel-buffer)))
122 (list riece-dialogue-buffer riece-others-buffer)
123 riece-dialogue-buffer)
125 (riece-concat-server-name
126 (format "CTCP VERSION from %s (%s) to %s"
128 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
129 (riece-format-identity target-identity t)))
132 (defun riece-handle-ctcp-ping-request (prefix target string)
133 (let* ((target-identity (riece-make-identity target riece-server-name))
134 (buffer (if (riece-channel-p target)
135 (riece-channel-buffer target-identity)))
136 (user (riece-prefix-nickname prefix)))
139 (format "NOTICE %s :\1PING %s\1\r\n" user string)
140 (format "NOTICE %s :\1PING\1\r\n" user string)))
141 (riece-insert-change buffer (format "CTCP PING from %s\n" user))
143 (if (and riece-channel-buffer-mode
144 (not (eq buffer riece-channel-buffer)))
145 (list riece-dialogue-buffer riece-others-buffer)
146 riece-dialogue-buffer)
148 (riece-concat-server-name
149 (format "CTCP PING from %s (%s) to %s"
151 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
152 (riece-format-identity target-identity t)))
155 (defun riece-handle-ctcp-clientinfo-request (prefix target string)
156 (let* ((target-identity (riece-make-identity target riece-server-name))
157 (buffer (if (riece-channel-p target)
158 (riece-channel-buffer target-identity)))
159 (user (riece-prefix-nickname prefix)))
161 (format "NOTICE %s :\1CLIENTINFO %s\1\r\n"
166 (let ((case-fold-search t))
167 (if (and (fboundp atom)
169 "riece-handle-ctcp-\\(.+\\)-request"
172 (cons (match-string 1 (symbol-name atom))
174 (mapconcat #'upcase (append messages
175 riece-ctcp-additional-clientinfo)
177 (riece-insert-change buffer (format "CTCP CLIENTINFO from %s\n" user))
179 (if (and riece-channel-buffer-mode
180 (not (eq buffer riece-channel-buffer)))
181 (list riece-dialogue-buffer riece-others-buffer)
182 riece-dialogue-buffer)
184 (riece-concat-server-name
185 (format "CTCP CLIENTINFO from %s (%s) to %s"
187 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
188 (riece-format-identity target-identity t)))
191 (defun riece-handle-ctcp-action-request (prefix target string)
192 (let ((buffer (if (riece-channel-p target)
193 (riece-channel-buffer (riece-make-identity
194 target riece-server-name))))
195 (user (riece-prefix-nickname prefix)))
196 (riece-insert buffer (concat riece-ctcp-action-prefix user " " string
199 (if (and riece-channel-buffer-mode
200 (not (eq buffer riece-channel-buffer)))
201 (list riece-dialogue-buffer riece-others-buffer)
202 riece-dialogue-buffer)
203 (concat (riece-concat-server-name (concat riece-ctcp-action-prefix user
204 " " string)) "\n"))))
206 (defun riece-handle-ctcp-response (prefix string)
207 (when (and prefix string
208 (riece-prefix-nickname prefix))
209 (let* ((parameters (riece-split-parameters string))
210 (targets (split-string (car parameters) ","))
211 (message (nth 1 parameters)))
212 (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message)
213 (let ((response (downcase (match-string 1 message))))
214 (if (match-beginning 2)
215 (setq message (substring (match-string 2 message) 1)))
217 (intern (concat "riece-ctcp-" response "-response-hook")))
218 (function (intern-soft (concat "riece-handle-ctcp-"
219 response "-response")))
221 (intern (concat "riece-ctcp-after-" response
223 (unless (condition-case error
224 (run-hook-with-args-until-success
225 hook prefix (car targets) message)
228 (message "Error in `%S': %S" hook error))
231 (condition-case error
232 (funcall function prefix (car targets) message)
235 (message "Error in `%S': %S"
237 (condition-case error
238 (run-hook-with-args-until-success
239 after-hook prefix (car targets) message)
242 (message "Error in `%S': %S"
243 after-hook error)))))
246 (defun riece-handle-ctcp-version-response (prefix target string)
248 (list riece-dialogue-buffer riece-others-buffer)
250 (riece-concat-server-name
251 (format "CTCP VERSION for %s (%s) = %s"
252 (riece-prefix-nickname prefix)
253 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
257 (defun riece-handle-ctcp-ping-response (prefix target string)
258 (let* ((now (current-time))
259 (elapsed (+ (* 65536 (- (car now) (car riece-ctcp-ping-time)))
260 (- (nth 1 now) (nth 1 riece-ctcp-ping-time)))))
262 (list riece-dialogue-buffer riece-others-buffer)
264 (riece-concat-server-name
265 (format "CTCP PING for %s (%s) = %d sec"
266 (riece-prefix-nickname prefix)
267 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
271 (defun riece-handle-ctcp-clientinfo-response (prefix target string)
273 (list riece-dialogue-buffer riece-others-buffer)
275 (riece-concat-server-name
276 (format "CTCP CLIENTINFO for %s (%s) = %s"
277 (riece-prefix-nickname prefix)
278 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
282 (defun riece-command-ctcp-version (target)
284 (list (riece-completing-read-identity
286 (riece-get-identities-on-server (riece-current-server-name)))))
287 (riece-send-string (format "PRIVMSG %s :\1VERSION\1\r\n"
288 (riece-identity-prefix target))))
290 (defun riece-command-ctcp-ping (target)
292 (list (riece-completing-read-identity
294 (riece-get-identities-on-server (riece-current-server-name)))))
295 (riece-send-string (format "PRIVMSG %s :\1PING\1\r\n"
296 (riece-identity-prefix target)))
297 (setq riece-ctcp-ping-time (current-time)))
299 (defun riece-command-ctcp-clientinfo (target)
301 (list (riece-completing-read-identity
303 (riece-get-identities-on-server (riece-current-server-name)))))
304 (riece-send-string (format "PRIVMSG %s :\1CLIENTINFO\1\r\n"
305 (riece-identity-prefix target))))
307 (defun riece-command-ctcp-action (target action)
309 (list (if current-prefix-arg
310 (riece-completing-read-identity
312 (riece-get-identities-on-server (riece-current-server-name)))
313 riece-current-channel)
316 (setq message (buffer-substring (point)
317 (progn (end-of-line) (point))))
318 (if (equal message "")
319 (read-string "Action: ")
320 (prog1 (read-from-minibuffer "Action: " (cons message 0))
321 (let ((next-line-add-newlines t))
323 (if (equal action "")
325 (riece-send-string (format "PRIVMSG %s :\1ACTION %s\1\r\n"
326 (riece-identity-prefix target)
328 (let ((buffer (riece-channel-buffer target)))
331 (concat riece-ctcp-action-prefix
332 (riece-identity-prefix (riece-current-nickname)) " " action "\n"))
334 (if (and riece-channel-buffer-mode
335 (not (eq buffer riece-channel-buffer)))
336 (list riece-dialogue-buffer riece-others-buffer)
337 riece-dialogue-buffer)
339 (riece-with-server-buffer (riece-identity-server target)
340 (riece-concat-server-name
341 (concat riece-ctcp-action-prefix
342 (riece-identity-prefix (riece-current-nickname)) " " action
343 " (in " (riece-format-identity target t) ")")))
346 (provide 'riece-ctcp)
348 ;;; riece-ctcp.el ends here