9bb7de3caf9305456a05358a51ea650993649da0
[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 user " " string
174                                  "\n"))
175     (riece-insert
176      (if (and riece-channel-buffer-mode
177               (not (eq buffer riece-channel-buffer)))
178          (list riece-dialogue-buffer riece-others-buffer)
179        riece-dialogue-buffer)
180      (concat (riece-concat-server-name (concat riece-ctcp-action-prefix user
181                                                " " string)) "\n"))))
182
183 (defun riece-handle-ctcp-time-request (prefix target string)
184   (let* ((target-identity (riece-make-identity target riece-server-name))
185          (buffer (if (riece-channel-p target)
186                      (riece-channel-buffer target-identity)))
187          (user (riece-prefix-nickname prefix))
188          (time (format-time-string "%c")))
189     (riece-send-string
190      (format "NOTICE %s :\1TIME %s\1\r\n" user time))
191     (riece-insert-change buffer (format "CTCP TIME from %s\n" user))
192     (riece-insert-change
193      (if (and riece-channel-buffer-mode
194               (not (eq buffer riece-channel-buffer)))
195          (list riece-dialogue-buffer riece-others-buffer)
196        riece-dialogue-buffer)
197      (concat
198       (riece-concat-server-name
199        (format "CTCP TIME from %s (%s) to %s"
200                user
201                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
202                (riece-format-identity target-identity t)))
203       "\n"))))
204
205 (defun riece-handle-ctcp-response (prefix string)
206   (when (and riece-ctcp-enabled prefix string
207              (riece-prefix-nickname prefix))
208     (let* ((parameters (riece-split-parameters string))
209            (targets (split-string (car parameters) ","))
210            (message (nth 1 parameters)))
211       (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message)
212           (let ((response (downcase (match-string 1 message))))
213             (if (match-beginning 2)
214                 (setq message (substring (match-string 2 message) 1)))
215             (let ((hook
216                    (intern (concat "riece-ctcp-" response "-response-hook")))
217                   (function (intern-soft (concat "riece-handle-ctcp-"
218                                                  response "-response")))
219                   (after-hook
220                    (intern (concat "riece-ctcp-after-" response
221                                    "-response-hook"))))
222               (unless (riece-ignore-errors (symbol-name hook)
223                         (run-hook-with-args-until-success
224                          hook prefix (car targets) message))
225                 (if function
226                     (riece-funcall-ignore-errors
227                      (symbol-name function)
228                      function prefix (car targets) message))
229                 (riece-ignore-errors (symbol-name after-hook)
230                   (run-hook-with-args-until-success
231                    after-hook prefix (car targets) message))))
232             t)))))
233
234 (defun riece-handle-ctcp-version-response (prefix target string)
235   (riece-insert-change
236    (list riece-dialogue-buffer riece-others-buffer)
237    (concat
238     (riece-concat-server-name
239      (format "CTCP VERSION for %s (%s) = %s"
240              (riece-prefix-nickname prefix)
241              (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
242              string))
243     "\n")))
244
245 (defun riece-handle-ctcp-ping-response (prefix target string)
246   (let* ((now (current-time))
247          (elapsed (+ (* 65536 (- (car now) (car riece-ctcp-ping-time)))
248                      (- (nth 1 now) (nth 1 riece-ctcp-ping-time)))))
249     (riece-insert-change
250      (list riece-dialogue-buffer riece-others-buffer)
251      (concat
252       (riece-concat-server-name
253        (format "CTCP PING for %s (%s) = %d sec"
254                (riece-prefix-nickname prefix)
255                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
256                elapsed))
257       "\n"))))
258
259 (defun riece-handle-ctcp-clientinfo-response (prefix target string)
260   (riece-insert-change
261    (list riece-dialogue-buffer riece-others-buffer)
262    (concat
263     (riece-concat-server-name
264      (format "CTCP CLIENTINFO for %s (%s) = %s"
265              (riece-prefix-nickname prefix)
266              (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
267              string))
268     "\n")))
269
270 (defun riece-handle-ctcp-time-response (prefix target string)
271   (riece-insert-change
272    (list riece-dialogue-buffer riece-others-buffer)
273    (concat
274     (riece-concat-server-name
275      (format "CTCP TIME for %s (%s) = %s"
276              (riece-prefix-nickname prefix)
277              (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
278              string))
279     "\n")))
280
281 (defun riece-command-ctcp-version (target)
282   (interactive
283    (list (riece-completing-read-identity
284           "Channel/User: "
285           (riece-get-identities-on-server (riece-current-server-name)))))
286   (riece-send-string (format "PRIVMSG %s :\1VERSION\1\r\n"
287                              (riece-identity-prefix target))))
288
289 (defun riece-command-ctcp-ping (target)
290   (interactive
291    (list (riece-completing-read-identity
292           "Channel/User: "
293           (riece-get-identities-on-server (riece-current-server-name)))))
294   (riece-send-string (format "PRIVMSG %s :\1PING\1\r\n"
295                              (riece-identity-prefix target)))
296   (setq riece-ctcp-ping-time (current-time)))
297
298 (defun riece-command-ctcp-clientinfo (target)
299   (interactive
300    (list (riece-completing-read-identity
301           "Channel/User: "
302           (riece-get-identities-on-server (riece-current-server-name)))))
303   (riece-send-string (format "PRIVMSG %s :\1CLIENTINFO\1\r\n"
304                              (riece-identity-prefix target))))
305
306 (defun riece-command-ctcp-action (target action)
307   (interactive
308    (list (if current-prefix-arg
309              (riece-completing-read-identity
310               "Channel/User: "
311               (riece-get-identities-on-server (riece-current-server-name)))
312            riece-current-channel)
313          (let (message)
314            (beginning-of-line)
315            (setq message (buffer-substring (point)
316                                            (progn (end-of-line) (point))))
317            (if (equal message "")
318                (read-string "Action: ")
319              (prog1 (read-from-minibuffer "Action: " (cons message 0))
320                (let ((next-line-add-newlines t))
321                  (next-line 1)))))))
322   (if (equal action "")
323       (error "No action"))
324   (riece-send-string (format "PRIVMSG %s :\1ACTION %s\1\r\n"
325                              (riece-identity-prefix target)
326                              action))
327   (let ((buffer (riece-channel-buffer target)))
328     (riece-insert
329      buffer
330      (concat riece-ctcp-action-prefix
331              (riece-identity-prefix (riece-current-nickname)) " " action "\n"))
332     (riece-insert
333      (if (and riece-channel-buffer-mode
334               (not (eq buffer riece-channel-buffer)))
335          (list riece-dialogue-buffer riece-others-buffer)
336        riece-dialogue-buffer)
337      (concat
338       (riece-with-server-buffer (riece-identity-server target)
339         (riece-concat-server-name
340          (concat riece-ctcp-action-prefix
341                  (riece-identity-prefix (riece-current-nickname)) " " action
342                  " (in " (riece-format-identity target t) ")")))
343       "\n"))))
344
345 (defun riece-command-ctcp-time (target)
346   (interactive
347    (list (riece-completing-read-identity
348           "Channel/User: "
349           (riece-get-identities-on-server (riece-current-server-name)))))
350   (riece-send-string (format "PRIVMSG %s :\1TIME\1\r\n"
351                              (riece-identity-prefix target))))
352
353 (defun riece-ctcp-requires ()
354   (if (memq 'riece-highlight riece-addons)
355       '(riece-highlight)))
356
357 (defun riece-ctcp-insinuate ()
358   (add-hook 'riece-privmsg-hook 'riece-handle-ctcp-request)
359   (add-hook 'riece-notice-hook 'riece-handle-ctcp-response)
360   (if (memq 'riece-highlight riece-addons)
361       (setq riece-dialogue-font-lock-keywords
362             (cons (list (concat "^" riece-time-prefix-regexp "\\("
363                                 (regexp-quote riece-ctcp-action-prefix)
364                                 ".*\\)$")
365                         1 riece-ctcp-action-face t t)
366                   riece-dialogue-font-lock-keywords))))
367
368 (defun riece-ctcp-enable ()
369   (define-key riece-dialogue-mode-map "\C-cv" 'riece-command-ctcp-version)
370   (define-key riece-dialogue-mode-map "\C-cp" 'riece-command-ctcp-ping)
371   (define-key riece-dialogue-mode-map "\C-ca" 'riece-command-ctcp-action)
372   (define-key riece-dialogue-mode-map "\C-cc" 'riece-command-ctcp-clientinfo)
373   (define-key riece-dialogue-mode-map "\C-ct" 'riece-command-ctcp-time)
374   (setq riece-ctcp-enabled t))
375
376 (defun riece-ctcp-disable ()
377   (define-key riece-dialogue-mode-map "\C-cv" nil)
378   (define-key riece-dialogue-mode-map "\C-cp" nil)
379   (define-key riece-dialogue-mode-map "\C-ca" nil)
380   (define-key riece-dialogue-mode-map "\C-cc" nil)
381   (define-key riece-dialogue-mode-map "\C-ct" nil)
382   (setq riece-ctcp-enabled nil))
383
384 (provide 'riece-ctcp)
385
386 ;;; riece-ctcp.el ends here