* riece-ctcp.el (riece-handle-ctcp-action-request): Prepend target.
[riece] / lisp / riece-ctcp.el
1 ;;; riece-ctcp.el --- CTCP add-on
2 ;; Copyright (C) 1998-2003 Daiki Ueno
3
4 ;; Author: Daiki Ueno <ueno@unixuser.org>
5 ;; Created: 1998-09-28
6 ;; Keywords: IRC, riece
7
8 ;; This file is part of Riece.
9
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)
13 ;; any later version.
14
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.
19
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.
24
25 ;;; Code:
26
27 (require 'riece-version)
28 (require 'riece-misc)
29 (require 'riece-highlight)
30 (require 'riece-display)
31 (require 'riece-debug)
32
33 (defface riece-ctcp-action-face
34   '((((class color)
35       (background dark))
36      (:foreground "PaleGreen" :italic t))
37     (((class color)
38       (background light))
39      (:foreground "ForestGreen" :italic t))
40     (t
41      (:bold t)))
42   "Face used for displaying \"*** Action:\" line"
43   :group 'riece-highlight-faces)
44 (defvar riece-ctcp-action-face 'riece-ctcp-action-face)
45
46 (defconst riece-ctcp-action-prefix "*** Action: ")
47
48 (defvar riece-ctcp-ping-time nil)
49 (defvar riece-ctcp-additional-clientinfo nil)
50
51 (defvar riece-dialogue-mode-map)
52
53 (defvar riece-ctcp-enabled nil)
54
55 (defconst riece-ctcp-description
56   "CTCP (Client To Client Protocol) support")
57
58 (defun riece-handle-ctcp-request (prefix string)
59   (when (and riece-ctcp-enabled prefix string
60              (riece-prefix-nickname prefix))
61     (let* ((parameters (riece-split-parameters string))
62            (targets (split-string (car parameters) ","))
63            (message (nth 1 parameters)))
64       (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message)
65           (let ((request (downcase (match-string 1 message))))
66             (if (match-beginning 2)
67                 (setq message (substring (match-string 2 message) 1)))
68             (let ((hook
69                    (intern (concat "riece-ctcp-" request "-request-hook")))
70                   (function
71                    (intern-soft (concat "riece-handle-ctcp-" request
72                                         "-request")))
73                   (after-hook
74                    (intern (concat "riece-ctcp-after-" request
75                                    "-request-hook"))))
76               (unless (riece-ignore-errors (symbol-name hook)
77                         (run-hook-with-args-until-success
78                          hook prefix (car targets) message))
79                 (if function
80                     (riece-funcall-ignore-errors (symbol-name function)
81                                                   function prefix (car targets)
82                                                   message))
83                 (riece-ignore-errors (symbol-name after-hook)
84                   (run-hook-with-args-until-success
85                    after-hook prefix (car targets) message))))
86             t)))))
87
88 (defun riece-handle-ctcp-version-request (prefix target string)
89   (let* ((target-identity (riece-make-identity target riece-server-name))
90          (buffer (if (riece-channel-p target)
91                      (riece-channel-buffer target-identity)))
92          (user (riece-prefix-nickname prefix)))
93     (riece-send-string
94      (format "NOTICE %s :\1VERSION %s\1\r\n" user (riece-extended-version)))
95     (riece-insert-change buffer (format "CTCP VERSION from %s\n" user))
96     (riece-insert-change
97      (if (and riece-channel-buffer-mode
98               (not (eq buffer riece-channel-buffer)))
99          (list riece-dialogue-buffer riece-others-buffer)
100        riece-dialogue-buffer)
101      (concat
102       (riece-concat-server-name
103        (format "CTCP VERSION from %s (%s) to %s"
104                user
105                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
106                (riece-format-identity target-identity t)))
107       "\n"))))
108
109 (defun riece-handle-ctcp-ping-request (prefix target string)
110   (let* ((target-identity (riece-make-identity target riece-server-name))
111          (buffer (if (riece-channel-p target)
112                      (riece-channel-buffer target-identity)))
113          (user (riece-prefix-nickname prefix)))
114     (riece-send-string
115      (if string
116          (format "NOTICE %s :\1PING %s\1\r\n" user string)
117        (format "NOTICE %s :\1PING\1\r\n" user string)))
118     (riece-insert-change buffer (format "CTCP PING from %s\n" user))
119     (riece-insert-change
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)
124      (concat
125       (riece-concat-server-name
126        (format "CTCP PING from %s (%s) to %s"
127                user
128                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
129                (riece-format-identity target-identity t)))
130       "\n"))))
131
132 (defun riece-handle-ctcp-clientinfo-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)))
137     (riece-send-string
138      (format "NOTICE %s :\1CLIENTINFO %s\1\r\n"
139              user
140              (let (messages)
141                (mapatoms
142                 (lambda (atom)
143                   (let ((case-fold-search t))
144                     (if (and (fboundp atom)
145                              (string-match
146                               "riece-handle-ctcp-\\(.+\\)-request"
147                               (symbol-name atom)))
148                         (setq messages
149                               (cons (match-string 1 (symbol-name atom))
150                                     messages))))))
151                (mapconcat #'upcase (append messages
152                                            riece-ctcp-additional-clientinfo)
153                           " "))))
154     (riece-insert-change buffer (format "CTCP CLIENTINFO from %s\n" user))
155     (riece-insert-change
156      (if (and riece-channel-buffer-mode
157               (not (eq buffer riece-channel-buffer)))
158          (list riece-dialogue-buffer riece-others-buffer)
159        riece-dialogue-buffer)
160      (concat
161       (riece-concat-server-name
162        (format "CTCP CLIENTINFO from %s (%s) to %s"
163                user
164                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
165                (riece-format-identity target-identity t)))
166       "\n"))))
167
168 (defun riece-handle-ctcp-action-request (prefix target string)
169   (let ((buffer (if (riece-channel-p target)
170                     (riece-channel-buffer (riece-make-identity
171                                            target riece-server-name))))
172         (user (riece-prefix-nickname prefix)))
173     (riece-insert buffer (concat riece-ctcp-action-prefix
174                                  (riece-format-identity
175                                   (riece-make-identity user riece-server-name)
176                                   t)
177                                  " " string
178                                  "\n"))
179     (riece-insert
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)
184      (concat (riece-concat-server-name
185               (concat riece-ctcp-action-prefix
186                       (riece-format-identity
187                        (riece-make-identity target riece-server-name)
188                        t)
189                       ": "
190                       (riece-format-identity
191                        (riece-make-identity user riece-server-name)
192                        t)
193                       " " string)) "\n"))))
194
195 (defun riece-handle-ctcp-time-request (prefix target string)
196   (let* ((target-identity (riece-make-identity target riece-server-name))
197          (buffer (if (riece-channel-p target)
198                      (riece-channel-buffer target-identity)))
199          (user (riece-prefix-nickname prefix))
200          (time (format-time-string "%c")))
201     (riece-send-string
202      (format "NOTICE %s :\1TIME %s\1\r\n" user time))
203     (riece-insert-change buffer (format "CTCP TIME from %s\n" user))
204     (riece-insert-change
205      (if (and riece-channel-buffer-mode
206               (not (eq buffer riece-channel-buffer)))
207          (list riece-dialogue-buffer riece-others-buffer)
208        riece-dialogue-buffer)
209      (concat
210       (riece-concat-server-name
211        (format "CTCP TIME from %s (%s) to %s"
212                user
213                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
214                (riece-format-identity target-identity t)))
215       "\n"))))
216
217 (defun riece-handle-ctcp-response (prefix string)
218   (when (and riece-ctcp-enabled prefix string
219              (riece-prefix-nickname prefix))
220     (let* ((parameters (riece-split-parameters string))
221            (targets (split-string (car parameters) ","))
222            (message (nth 1 parameters)))
223       (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message)
224           (let ((response (downcase (match-string 1 message))))
225             (if (match-beginning 2)
226                 (setq message (substring (match-string 2 message) 1)))
227             (let ((hook
228                    (intern (concat "riece-ctcp-" response "-response-hook")))
229                   (function (intern-soft (concat "riece-handle-ctcp-"
230                                                  response "-response")))
231                   (after-hook
232                    (intern (concat "riece-ctcp-after-" response
233                                    "-response-hook"))))
234               (unless (riece-ignore-errors (symbol-name hook)
235                         (run-hook-with-args-until-success
236                          hook prefix (car targets) message))
237                 (if function
238                     (riece-funcall-ignore-errors
239                      (symbol-name function)
240                      function prefix (car targets) message))
241                 (riece-ignore-errors (symbol-name after-hook)
242                   (run-hook-with-args-until-success
243                    after-hook prefix (car targets) message))))
244             t)))))
245
246 (defun riece-handle-ctcp-version-response (prefix target string)
247   (riece-insert-change
248    (list riece-dialogue-buffer riece-others-buffer)
249    (concat
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))
254              string))
255     "\n")))
256
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)))))
261     (riece-insert-change
262      (list riece-dialogue-buffer riece-others-buffer)
263      (concat
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))
268                elapsed))
269       "\n"))))
270
271 (defun riece-handle-ctcp-clientinfo-response (prefix target string)
272   (riece-insert-change
273    (list riece-dialogue-buffer riece-others-buffer)
274    (concat
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))
279              string))
280     "\n")))
281
282 (defun riece-handle-ctcp-time-response (prefix target string)
283   (riece-insert-change
284    (list riece-dialogue-buffer riece-others-buffer)
285    (concat
286     (riece-concat-server-name
287      (format "CTCP TIME for %s (%s) = %s"
288              (riece-prefix-nickname prefix)
289              (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
290              string))
291     "\n")))
292
293 (defun riece-command-ctcp-version (target)
294   (interactive
295    (list (riece-completing-read-identity
296           "Channel/User: "
297           (riece-get-identities-on-server (riece-current-server-name)))))
298   (riece-send-string (format "PRIVMSG %s :\1VERSION\1\r\n"
299                              (riece-identity-prefix target))))
300
301 (defun riece-command-ctcp-ping (target)
302   (interactive
303    (list (riece-completing-read-identity
304           "Channel/User: "
305           (riece-get-identities-on-server (riece-current-server-name)))))
306   (riece-send-string (format "PRIVMSG %s :\1PING\1\r\n"
307                              (riece-identity-prefix target)))
308   (setq riece-ctcp-ping-time (current-time)))
309
310 (defun riece-command-ctcp-clientinfo (target)
311   (interactive
312    (list (riece-completing-read-identity
313           "Channel/User: "
314           (riece-get-identities-on-server (riece-current-server-name)))))
315   (riece-send-string (format "PRIVMSG %s :\1CLIENTINFO\1\r\n"
316                              (riece-identity-prefix target))))
317
318 (defun riece-command-ctcp-action (target action)
319   (interactive
320    (list (if current-prefix-arg
321              (riece-completing-read-identity
322               "Channel/User: "
323               (riece-get-identities-on-server (riece-current-server-name)))
324            riece-current-channel)
325          (let (message)
326            (beginning-of-line)
327            (setq message (buffer-substring (point)
328                                            (progn (end-of-line) (point))))
329            (if (equal message "")
330                (read-string "Action: ")
331              (prog1 (read-from-minibuffer "Action: " (cons message 0))
332                (let ((next-line-add-newlines t))
333                  (next-line 1)))))))
334   (if (equal action "")
335       (error "No action"))
336   (riece-send-string (format "PRIVMSG %s :\1ACTION %s\1\r\n"
337                              (riece-identity-prefix target)
338                              action))
339   (let ((buffer (riece-channel-buffer target)))
340     (riece-insert
341      buffer
342      (concat riece-ctcp-action-prefix
343              (riece-identity-prefix (riece-current-nickname)) " " action "\n"))
344     (riece-insert
345      (if (and riece-channel-buffer-mode
346               (not (eq buffer riece-channel-buffer)))
347          (list riece-dialogue-buffer riece-others-buffer)
348        riece-dialogue-buffer)
349      (concat
350       (riece-with-server-buffer (riece-identity-server target)
351         (riece-concat-server-name
352          (concat riece-ctcp-action-prefix
353                  (riece-format-identity target t) ": "
354                  (riece-identity-prefix (riece-current-nickname)) " " action)))
355       "\n"))))
356
357 (defun riece-command-ctcp-time (target)
358   (interactive
359    (list (riece-completing-read-identity
360           "Channel/User: "
361           (riece-get-identities-on-server (riece-current-server-name)))))
362   (riece-send-string (format "PRIVMSG %s :\1TIME\1\r\n"
363                              (riece-identity-prefix target))))
364
365 (defun riece-ctcp-requires ()
366   (if (memq 'riece-highlight riece-addons)
367       '(riece-highlight)))
368
369 (defun riece-ctcp-insinuate ()
370   (add-hook 'riece-privmsg-hook 'riece-handle-ctcp-request)
371   (add-hook 'riece-notice-hook 'riece-handle-ctcp-response)
372   (if (memq 'riece-highlight riece-addons)
373       (setq riece-dialogue-font-lock-keywords
374             (cons (list (concat "^" riece-time-prefix-regexp "\\("
375                                 (regexp-quote riece-ctcp-action-prefix)
376                                 ".*\\)$")
377                         1 riece-ctcp-action-face t t)
378                   riece-dialogue-font-lock-keywords))))
379
380 (defun riece-ctcp-enable ()
381   (define-key riece-dialogue-mode-map "\C-cv" 'riece-command-ctcp-version)
382   (define-key riece-dialogue-mode-map "\C-cp" 'riece-command-ctcp-ping)
383   (define-key riece-dialogue-mode-map "\C-ca" 'riece-command-ctcp-action)
384   (define-key riece-dialogue-mode-map "\C-cc" 'riece-command-ctcp-clientinfo)
385   (define-key riece-dialogue-mode-map "\C-ct" 'riece-command-ctcp-time)
386   (setq riece-ctcp-enabled t))
387
388 (defun riece-ctcp-disable ()
389   (define-key riece-dialogue-mode-map "\C-cv" nil)
390   (define-key riece-dialogue-mode-map "\C-cp" nil)
391   (define-key riece-dialogue-mode-map "\C-ca" nil)
392   (define-key riece-dialogue-mode-map "\C-cc" nil)
393   (define-key riece-dialogue-mode-map "\C-ct" nil)
394   (setq riece-ctcp-enabled nil))
395
396 (provide 'riece-ctcp)
397
398 ;;; riece-ctcp.el ends here