9406b12d50a9acbe062096ef4dd74b5bc1451196
[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-display)
30
31 (defvar riece-ctcp-ping-time nil)
32 (defvar riece-ctcp-additional-clientinfo nil)
33
34 (defvar riece-dialogue-mode-map)
35
36 (defun riece-ctcp-insinuate ()
37   (add-hook 'riece-privmsg-hook 'riece-handle-ctcp-request)
38   (add-hook 'riece-notice-hook 'riece-handle-ctcp-response)
39   (define-key riece-dialogue-mode-map "\C-cv" 'riece-command-ctcp-version)
40   (define-key riece-dialogue-mode-map "\C-cp" 'riece-command-ctcp-ping)
41   (define-key riece-dialogue-mode-map "\C-ca" 'riece-command-ctcp-action)
42   (define-key riece-dialogue-mode-map "\C-cc" 'riece-command-ctcp-clientinfo))
43
44 (defun riece-handle-ctcp-request (prefix string)
45   (when (and prefix string
46              (riece-prefix-nickname prefix))
47     (let* ((parameters (riece-split-parameters string))
48            (targets (split-string (car parameters) ","))
49            (message (nth 1 parameters)))
50       (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message)
51           (let ((request (downcase (match-string 1 message))))
52             (if (match-beginning 2)
53                 (setq message (substring (match-string 2 message) 1)))
54             (let ((hook
55                    (intern (concat "riece-ctcp-" request "-request-hook")))
56                   (function
57                    (intern-soft (concat "riece-handle-ctcp-" request
58                                         "-request")))
59                   (after-hook
60                    (intern (concat "riece-ctcp-after-" request
61                                    "-request-hook"))))
62               (unless (condition-case error
63                           (run-hook-with-args-until-success
64                            hook prefix (car targets) message)
65                         (error
66                          (if riece-debug
67                              (message "Error occurred in `%S': %S" hook error))
68                          nil))
69                 (if function
70                     (condition-case error
71                         (funcall function prefix (car targets) message)
72                       (error
73                        (if riece-debug
74                            (message "Error occurred in `%S': %S"
75                                     function error))))))
76               (condition-case error
77                   (run-hook-with-args-until-success
78                    after-hook prefix (car targets) message)
79                 (error
80                  (if riece-debug
81                      (message "Error occurred in `%S': %S"
82                               after-hook error)))))
83             t)))))
84
85 (defun riece-handle-ctcp-version-request (prefix target string)
86   (let ((buffer (if (riece-channel-p target)
87                     (riece-channel-buffer (riece-make-identity
88                                            target riece-server-name))))
89         (user (riece-prefix-nickname prefix)))
90     (riece-send-string
91      (format "NOTICE %s :\1VERSION %s\1\r\n" user (riece-extended-version)))
92     (riece-insert-change buffer (format "CTCP VERSION from %s\n" user))
93     (riece-insert-change
94      (if (and riece-channel-buffer-mode
95               (not (eq buffer riece-channel-buffer)))
96          (list riece-dialogue-buffer riece-others-buffer)
97        riece-dialogue-buffer)
98      (concat
99       (riece-concat-server-name
100        (format "CTCP VERSION from %s (%s) to %s"
101                user
102                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
103                target))
104       "\n"))))
105
106 (defun riece-handle-ctcp-ping-request (prefix target string)
107   (let ((buffer (if (riece-channel-p target)
108                     (riece-channel-buffer (riece-make-identity
109                                            target riece-server-name))))
110         (user (riece-prefix-nickname prefix)))
111     (riece-send-string
112      (if string
113          (format "NOTICE %s :\1PING %s\1\r\n" user string)
114        (format "NOTICE %s :\1PING\1\r\n" user string)))
115     (riece-insert-change buffer (format "CTCP PING from %s\n" user))
116     (riece-insert-change
117      (if (and riece-channel-buffer-mode
118               (not (eq buffer riece-channel-buffer)))
119          (list riece-dialogue-buffer riece-others-buffer)
120        riece-dialogue-buffer)
121      (concat
122       (riece-concat-server-name
123        (format "CTCP PING from %s (%s) to %s"
124                user
125                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
126                target))
127       "\n"))))
128
129 (defun riece-handle-ctcp-clientinfo-request (prefix target string)
130   (let ((buffer (if (riece-channel-p target)
131                     (riece-channel-buffer (riece-make-identity
132                                            target riece-server-name))))
133         (user (riece-prefix-nickname prefix)))
134     (riece-send-string
135      (format "NOTICE %s :\1CLIENTINFO %s\1\r\n"
136              user
137              (let (messages)
138                (mapatoms
139                 (lambda (atom)
140                   (let ((case-fold-search t))
141                     (if (and (fboundp atom)
142                              (string-match
143                               "riece-handle-ctcp-\\(.+\\)-request"
144                               (symbol-name atom)))
145                         (setq messages
146                               (cons (match-string 1 (symbol-name atom))
147                                     messages))))))
148                (mapconcat #'upcase (append messages
149                                            riece-ctcp-additional-clientinfo)
150                           " "))))
151     (riece-insert-change buffer (format "CTCP CLIENTINFO from %s\n" user))
152     (riece-insert-change
153      (if (and riece-channel-buffer-mode
154               (not (eq buffer riece-channel-buffer)))
155          (list riece-dialogue-buffer riece-others-buffer)
156        riece-dialogue-buffer)
157      (concat
158       (riece-concat-server-name
159        (format "CTCP CLIENTINFO from %s (%s) to %s"
160                user
161                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
162                target))
163       "\n"))))
164
165 (defun riece-handle-ctcp-action-request (prefix target string)
166   (let ((buffer (if (riece-channel-p target)
167                     (riece-channel-buffer (riece-make-identity
168                                            target riece-server-name))))
169         (user (riece-prefix-nickname prefix)))
170     (riece-insert-change buffer (concat user " " string "\n"))
171     (riece-insert-change
172      (if (and riece-channel-buffer-mode
173               (not (eq buffer riece-channel-buffer)))
174          (list riece-dialogue-buffer riece-others-buffer)
175        riece-dialogue-buffer)
176      (concat (riece-concat-server-name (concat user " " string)) "\n"))))
177
178 (defun riece-handle-ctcp-response (prefix string)
179   (when (and prefix string
180              (riece-prefix-nickname prefix))
181     (let* ((parameters (riece-split-parameters string))
182            (targets (split-string (car parameters) ","))
183            (message (nth 1 parameters)))
184       (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message)
185           (let ((response (downcase (match-string 1 message))))
186             (if (match-beginning 2)
187                 (setq message (substring (match-string 2 message) 1)))
188             (let ((hook
189                    (intern (concat "riece-ctcp-" response "-response-hook")))
190                   (function (intern-soft (concat "riece-handle-ctcp-"
191                                                  response "-response")))
192                   (after-hook
193                    (intern (concat "riece-ctcp-after-" response
194                                    "-response-hook"))))
195               (unless (condition-case error
196                           (run-hook-with-args-until-success
197                            hook prefix (car targets) message)
198                         (error
199                          (if riece-debug
200                              (message "Error occurred in `%S': %S" hook error))
201                          nil))
202                 (if function
203                     (condition-case error
204                         (funcall function prefix (car targets) message)
205                       (error
206                        (if riece-debug
207                            (message "Error occurred in `%S': %S"
208                                     function error))))))
209               (condition-case error
210                   (run-hook-with-args-until-success
211                    after-hook prefix (car targets) message)
212                 (error
213                  (if riece-debug
214                      (message "Error occurred in `%S': %S"
215                               after-hook error)))))
216             t)))))
217
218 (defun riece-handle-ctcp-version-response (prefix target string)
219   (riece-insert-change
220    (list riece-dialogue-buffer riece-others-buffer)
221    (concat
222     (riece-concat-server-name
223      (format "CTCP VERSION for %s (%s) = %s"
224              (riece-prefix-nickname prefix)
225              (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
226              string))
227     "\n")))
228
229 (defun riece-handle-ctcp-ping-response (prefix target string)
230   (let* ((now (current-time))
231          (elapsed (+ (* 65536 (- (car now) (car riece-ctcp-ping-time)))
232                      (- (nth 1 now) (nth 1 riece-ctcp-ping-time)))))
233     (riece-insert-change
234      (list riece-dialogue-buffer riece-others-buffer)
235      (concat
236       (riece-concat-server-name
237        (format "CTCP PING for %s (%s) = %d sec"
238                (riece-prefix-nickname prefix)
239                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
240                elapsed))
241       "\n"))))
242
243 (defun riece-handle-ctcp-clientinfo-response (prefix target string)
244   (riece-insert-change
245    (list riece-dialogue-buffer riece-others-buffer)
246    (concat
247     (riece-concat-server-name
248      (format "CTCP CLIENTINFO for %s (%s) = %s"
249              (riece-prefix-nickname prefix)
250              (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
251              string))
252     "\n")))
253
254 (defun riece-ctcp-completing-read-identity ()
255   (riece-completing-read-identity
256    "Channel/User: "
257    (let ((server-name (riece-current-server-name)))
258      (append (mapcar
259               (lambda (user)
260                 (riece-make-identity user server-name))
261               (riece-get-users-on-server))
262              riece-current-channels))))
263
264 (defun riece-command-ctcp-version (user)
265   (interactive
266    (list (riece-ctcp-completing-read-identity)))
267   (riece-send-string (format "PRIVMSG %s :\1VERSION\1\r\n" user)))
268
269 (defun riece-command-ctcp-ping (user)
270   (interactive
271    (list (riece-ctcp-completing-read-identity)))
272   (riece-send-string (format "PRIVMSG %s :\1PING\1\r\n" user))
273   (setq riece-ctcp-ping-time (current-time)))
274
275 (defun riece-command-ctcp-clientinfo (user)
276   (interactive
277    (list (riece-ctcp-completing-read-identity)))
278   (riece-send-string (format "PRIVMSG %s :\1CLIENTINFO\1\r\n" user)))
279
280 (defun riece-command-ctcp-action (channel action)
281   (interactive
282    (list (if current-prefix-arg
283              (riece-ctcp-completing-read-identity)
284            riece-current-channel)
285          (read-string "Action: ")))
286   (if (equal action "")
287       (error "No action"))
288   (riece-send-string (format "PRIVMSG %s :\1ACTION %s\1\r\n"
289                              (riece-identity-prefix channel)
290                              action))
291   (let ((buffer (riece-channel-buffer channel)))
292     (riece-insert-change
293      buffer
294      (concat (riece-identity-prefix (riece-current-nickname)) " " action "\n"))
295     (riece-insert-change
296      (if (and riece-channel-buffer-mode
297               (not (eq buffer riece-channel-buffer)))
298          (list riece-dialogue-buffer riece-others-buffer)
299        riece-dialogue-buffer)
300      (concat
301       (riece-concat-server-name
302        (concat (riece-identity-prefix (riece-current-nickname)) " " action))
303       "\n"))))
304
305 (provide 'riece-ctcp)
306
307 ;;; riece-ctcp.el ends here