2005-02-18 Steve Youngs <steve@sxemacs.org>
[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-ignore-errors (symbol-name function)
81                       (funcall function prefix (car targets) message)))
82                 (riece-ignore-errors (symbol-name after-hook)
83                   (run-hook-with-args-until-success
84                    after-hook prefix (car targets) message))))
85             t)))))
86
87 (defun riece-handle-ctcp-version-request (prefix target string)
88   (let* ((target-identity (riece-make-identity target riece-server-name))
89          (buffer (if (riece-channel-p target)
90                      (riece-channel-buffer target-identity)))
91          (user (riece-prefix-nickname prefix)))
92     (riece-send-string
93      (format "NOTICE %s :\1VERSION %s\1\r\n" user (riece-extended-version)))
94     (riece-insert-change buffer (format "CTCP VERSION from %s\n" user))
95     (riece-insert-change
96      (if (and riece-channel-buffer-mode
97               (not (eq buffer riece-channel-buffer)))
98          (list riece-dialogue-buffer riece-others-buffer)
99        riece-dialogue-buffer)
100      (concat
101       (riece-concat-server-name
102        (format "CTCP VERSION from %s (%s) to %s"
103                user
104                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
105                (riece-format-identity target-identity t)))
106       "\n"))))
107
108 (defun riece-handle-ctcp-ping-request (prefix target string)
109   (let* ((target-identity (riece-make-identity target riece-server-name))
110          (buffer (if (riece-channel-p target)
111                      (riece-channel-buffer target-identity)))
112          (user (riece-prefix-nickname prefix)))
113     (riece-send-string
114      (if string
115          (format "NOTICE %s :\1PING %s\1\r\n" user string)
116        (format "NOTICE %s :\1PING\1\r\n" user string)))
117     (riece-insert-change buffer (format "CTCP PING from %s\n" user))
118     (riece-insert-change
119      (if (and riece-channel-buffer-mode
120               (not (eq buffer riece-channel-buffer)))
121          (list riece-dialogue-buffer riece-others-buffer)
122        riece-dialogue-buffer)
123      (concat
124       (riece-concat-server-name
125        (format "CTCP PING from %s (%s) to %s"
126                user
127                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
128                (riece-format-identity target-identity t)))
129       "\n"))))
130
131 (defun riece-handle-ctcp-clientinfo-request (prefix target string)
132   (let* ((target-identity (riece-make-identity target riece-server-name))
133          (buffer (if (riece-channel-p target)
134                      (riece-channel-buffer target-identity)))
135          (user (riece-prefix-nickname prefix)))
136     (riece-send-string
137      (format "NOTICE %s :\1CLIENTINFO %s\1\r\n"
138              user
139              (let (messages)
140                (mapatoms
141                 (lambda (atom)
142                   (let ((case-fold-search t))
143                     (if (and (fboundp atom)
144                              (string-match
145                               "riece-handle-ctcp-\\(.+\\)-request"
146                               (symbol-name atom)))
147                         (setq messages
148                               (cons (match-string 1 (symbol-name atom))
149                                     messages))))))
150                (mapconcat #'upcase (append messages
151                                            riece-ctcp-additional-clientinfo)
152                           " "))))
153     (riece-insert-change buffer (format "CTCP CLIENTINFO from %s\n" user))
154     (riece-insert-change
155      (if (and riece-channel-buffer-mode
156               (not (eq buffer riece-channel-buffer)))
157          (list riece-dialogue-buffer riece-others-buffer)
158        riece-dialogue-buffer)
159      (concat
160       (riece-concat-server-name
161        (format "CTCP CLIENTINFO from %s (%s) to %s"
162                user
163                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
164                (riece-format-identity target-identity t)))
165       "\n"))))
166
167 (defun riece-handle-ctcp-action-request (prefix target string)
168   (let ((buffer (if (riece-channel-p target)
169                     (riece-channel-buffer (riece-make-identity
170                                            target riece-server-name))))
171         (user (riece-prefix-nickname prefix)))
172     (riece-insert buffer (concat riece-ctcp-action-prefix user " " string
173                                  "\n"))
174     (riece-insert
175      (if (and riece-channel-buffer-mode
176               (not (eq buffer riece-channel-buffer)))
177          (list riece-dialogue-buffer riece-others-buffer)
178        riece-dialogue-buffer)
179      (concat (riece-concat-server-name (concat riece-ctcp-action-prefix user
180                                                " " string)) "\n"))))
181
182 (defun riece-handle-ctcp-time-request (prefix target string)
183   (let* ((target-identity (riece-make-identity target riece-server-name))
184          (buffer (if (riece-channel-p target)
185                      (riece-channel-buffer target-identity)))
186          (user (riece-prefix-nickname prefix))
187          (time (format-time-string "%c")))
188     (riece-send-string
189      (format "NOTICE %s :\1TIME %s\1\r\n" user time))
190     (riece-insert-change buffer (format "CTCP TIME from %s\n" user))
191     (riece-insert-change
192      (if (and riece-channel-buffer-mode
193               (not (eq buffer riece-channel-buffer)))
194          (list riece-dialogue-buffer riece-others-buffer)
195        riece-dialogue-buffer)
196      (concat
197       (riece-concat-server-name
198        (format "CTCP TIME from %s (%s) to %s"
199                user
200                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
201                (riece-format-identity target-identity t)))
202       "\n"))))
203
204 (defun riece-handle-ctcp-response (prefix string)
205   (when (and riece-ctcp-enabled prefix string
206              (riece-prefix-nickname prefix))
207     (let* ((parameters (riece-split-parameters string))
208            (targets (split-string (car parameters) ","))
209            (message (nth 1 parameters)))
210       (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message)
211           (let ((response (downcase (match-string 1 message))))
212             (if (match-beginning 2)
213                 (setq message (substring (match-string 2 message) 1)))
214             (let ((hook
215                    (intern (concat "riece-ctcp-" response "-response-hook")))
216                   (function (intern-soft (concat "riece-handle-ctcp-"
217                                                  response "-response")))
218                   (after-hook
219                    (intern (concat "riece-ctcp-after-" response
220                                    "-response-hook"))))
221               (unless (riece-ignore-errors (symbol-name hook)
222                         (run-hook-with-args-until-success
223                          hook prefix (car targets) message))
224                 (if function
225                     (riece-ignore-errors (symbol-name function)
226                       (funcall function prefix (car targets) message)))
227                 (riece-ignore-errors (symbol-name after-hook)
228                   (run-hook-with-args-until-success
229                    after-hook prefix (car targets) message))))
230             t)))))
231
232 (defun riece-handle-ctcp-version-response (prefix target string)
233   (riece-insert-change
234    (list riece-dialogue-buffer riece-others-buffer)
235    (concat
236     (riece-concat-server-name
237      (format "CTCP VERSION for %s (%s) = %s"
238              (riece-prefix-nickname prefix)
239              (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
240              string))
241     "\n")))
242
243 (defun riece-handle-ctcp-ping-response (prefix target string)
244   (let* ((now (current-time))
245          (elapsed (+ (* 65536 (- (car now) (car riece-ctcp-ping-time)))
246                      (- (nth 1 now) (nth 1 riece-ctcp-ping-time)))))
247     (riece-insert-change
248      (list riece-dialogue-buffer riece-others-buffer)
249      (concat
250       (riece-concat-server-name
251        (format "CTCP PING for %s (%s) = %d sec"
252                (riece-prefix-nickname prefix)
253                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
254                elapsed))
255       "\n"))))
256
257 (defun riece-handle-ctcp-clientinfo-response (prefix target string)
258   (riece-insert-change
259    (list riece-dialogue-buffer riece-others-buffer)
260    (concat
261     (riece-concat-server-name
262      (format "CTCP CLIENTINFO for %s (%s) = %s"
263              (riece-prefix-nickname prefix)
264              (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
265              string))
266     "\n")))
267
268 (defun riece-handle-ctcp-time-response (prefix target string)
269   (riece-insert-change
270    (list riece-dialogue-buffer riece-others-buffer)
271    (concat
272     (riece-concat-server-name
273      (format "CTCP TIME for %s (%s) = %s"
274              (riece-prefix-nickname prefix)
275              (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
276              string))
277     "\n")))
278
279 (defun riece-command-ctcp-version (target)
280   (interactive
281    (list (riece-completing-read-identity
282           "Channel/User: "
283           (riece-get-identities-on-server (riece-current-server-name)))))
284   (riece-send-string (format "PRIVMSG %s :\1VERSION\1\r\n"
285                              (riece-identity-prefix target))))
286
287 (defun riece-command-ctcp-ping (target)
288   (interactive
289    (list (riece-completing-read-identity
290           "Channel/User: "
291           (riece-get-identities-on-server (riece-current-server-name)))))
292   (riece-send-string (format "PRIVMSG %s :\1PING\1\r\n"
293                              (riece-identity-prefix target)))
294   (setq riece-ctcp-ping-time (current-time)))
295
296 (defun riece-command-ctcp-clientinfo (target)
297   (interactive
298    (list (riece-completing-read-identity
299           "Channel/User: "
300           (riece-get-identities-on-server (riece-current-server-name)))))
301   (riece-send-string (format "PRIVMSG %s :\1CLIENTINFO\1\r\n"
302                              (riece-identity-prefix target))))
303
304 (defun riece-command-ctcp-action (target action)
305   (interactive
306    (list (if current-prefix-arg
307              (riece-completing-read-identity
308               "Channel/User: "
309               (riece-get-identities-on-server (riece-current-server-name)))
310            riece-current-channel)
311          (let (message)
312            (beginning-of-line)
313            (setq message (buffer-substring (point)
314                                            (progn (end-of-line) (point))))
315            (if (equal message "")
316                (read-string "Action: ")
317              (prog1 (read-from-minibuffer "Action: " (cons message 0))
318                (let ((next-line-add-newlines t))
319                  (next-line 1)))))))
320   (if (equal action "")
321       (error "No action"))
322   (riece-send-string (format "PRIVMSG %s :\1ACTION %s\1\r\n"
323                              (riece-identity-prefix target)
324                              action))
325   (let ((buffer (riece-channel-buffer target)))
326     (riece-insert
327      buffer
328      (concat riece-ctcp-action-prefix
329              (riece-identity-prefix (riece-current-nickname)) " " action "\n"))
330     (riece-insert
331      (if (and riece-channel-buffer-mode
332               (not (eq buffer riece-channel-buffer)))
333          (list riece-dialogue-buffer riece-others-buffer)
334        riece-dialogue-buffer)
335      (concat
336       (riece-with-server-buffer (riece-identity-server target)
337         (riece-concat-server-name
338          (concat riece-ctcp-action-prefix
339                  (riece-identity-prefix (riece-current-nickname)) " " action
340                  " (in " (riece-format-identity target t) ")")))
341       "\n"))))
342
343 (defun riece-command-ctcp-time (target)
344   (interactive
345    (list (riece-completing-read-identity
346           "Channel/User: "
347           (riece-get-identities-on-server (riece-current-server-name)))))
348   (riece-send-string (format "PRIVMSG %s :\1TIME\1\r\n"
349                              (riece-identity-prefix target))))
350
351 (defun riece-ctcp-requires ()
352   (if (memq 'riece-highlight riece-addons)
353       '(riece-highlight)))
354
355 (defun riece-ctcp-insinuate ()
356   (add-hook 'riece-privmsg-hook 'riece-handle-ctcp-request)
357   (add-hook 'riece-notice-hook 'riece-handle-ctcp-response)
358   (if (memq 'riece-highlight riece-addons)
359       (setq riece-dialogue-font-lock-keywords
360             (cons (list (concat "^" riece-time-prefix-regexp "\\("
361                                 (regexp-quote riece-ctcp-action-prefix)
362                                 ".*\\)$")
363                         1 riece-ctcp-action-face t t)
364                   riece-dialogue-font-lock-keywords))))
365
366 (defun riece-ctcp-enable ()
367   (define-key riece-dialogue-mode-map "\C-cv" 'riece-command-ctcp-version)
368   (define-key riece-dialogue-mode-map "\C-cp" 'riece-command-ctcp-ping)
369   (define-key riece-dialogue-mode-map "\C-ca" 'riece-command-ctcp-action)
370   (define-key riece-dialogue-mode-map "\C-cc" 'riece-command-ctcp-clientinfo)
371   (define-key riece-dialogue-mode-map "\C-ct" 'riece-command-ctcp-time)
372   (setq riece-ctcp-enabled t))
373
374 (defun riece-ctcp-disable ()
375   (define-key riece-dialogue-mode-map "\C-cv" nil)
376   (define-key riece-dialogue-mode-map "\C-cp" nil)
377   (define-key riece-dialogue-mode-map "\C-ca" nil)
378   (define-key riece-dialogue-mode-map "\C-cc" nil)
379   (define-key riece-dialogue-mode-map "\C-ct" nil)
380   (setq riece-ctcp-enabled nil))
381
382 (provide 'riece-ctcp)
383
384 ;;; riece-ctcp.el ends here