Support Scandinavian alphabets, described in RFC2812, 2.2.
[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
30 (defvar riece-ctcp-ping-time nil)
31 (defvar riece-ctcp-additional-clientinfo nil)
32
33 (defvar riece-dialogue-mode-map)
34
35 (defun riece-ctcp-insinuate ()
36   (add-hook 'riece-privmsg-hook 'riece-handle-ctcp-request)
37   (add-hook 'riece-notice-hook 'riece-handle-ctcp-response)
38   (define-key riece-dialogue-mode-map "\C-cv" 'riece-command-ctcp-version)
39   (define-key riece-dialogue-mode-map "\C-cp" 'riece-command-ctcp-ping)
40   (define-key riece-dialogue-mode-map "\C-ca" 'riece-command-ctcp-action)
41   (define-key riece-dialogue-mode-map "\C-cc" 'riece-command-ctcp-clientinfo))
42
43 (defun riece-handle-ctcp-request (prefix string)
44   (when (and prefix string
45              (riece-prefix-nickname prefix))
46     (let* ((parameters (riece-split-parameters string))
47            (targets (split-string (car parameters) ","))
48            (message (nth 1 parameters)))
49       (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message)
50           (let ((request (downcase (match-string 1 message))))
51             (if (match-beginning 2)
52                 (setq message (substring (match-string 2 message) 1)))
53             (let ((hook
54                    (intern (concat "riece-ctcp-" request "-request-hook")))
55                   (function
56                    (intern-soft (concat "riece-handle-ctcp-" request
57                                         "-request")))
58                   (after-hook
59                    (intern (concat "riece-ctcp-after-" request
60                                    "-request-hook"))))
61               (unless (condition-case error
62                           (run-hook-with-args-until-success
63                            hook prefix (car targets) message)
64                         (error
65                          (if riece-debug
66                              (message "Error occurred in `%S': %S" hook error))
67                          nil))
68                 (if function
69                     (condition-case error
70                         (funcall function prefix (car targets) message)
71                       (error
72                        (if riece-debug
73                            (message "Error occurred in `%S': %S"
74                                     function error))))))
75               (condition-case error
76                   (run-hook-with-args-until-success
77                    after-hook prefix (car targets) message)
78                 (error
79                  (if riece-debug
80                      (message "Error occurred in `%S': %S"
81                               after-hook error)))))
82             t)))))
83
84 (defun riece-handle-ctcp-version-request (prefix target string)
85   (let ((buffer (if (riece-channel-p target)
86                     (cdr (riece-identity-assoc
87                           (riece-make-identity target)
88                           riece-channel-buffer-alist))))
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                     (cdr (riece-identity-assoc
109                           (riece-make-identity target)
110                           riece-channel-buffer-alist))))
111         (user (riece-prefix-nickname prefix)))
112     (riece-send-string
113      (if string
114          (format "NOTICE %s :\1PING %s\1\r\n" user string)
115        (format "NOTICE %s :\1PING\1\r\n" user string)))
116     (riece-insert-change buffer (format "CTCP PING from %s\n" user))
117     (riece-insert-change
118      (if (and riece-channel-buffer-mode
119               (not (eq buffer riece-channel-buffer)))
120          (list riece-dialogue-buffer riece-others-buffer)
121        riece-dialogue-buffer)
122      (concat
123       (riece-concat-server-name
124        (format "CTCP PING from %s (%s) to %s"
125                user
126                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
127                target))
128       "\n"))))
129
130 (defun riece-handle-ctcp-clientinfo-request (prefix target string)
131   (let ((buffer (if (riece-channel-p target)
132                     (cdr (riece-identity-assoc
133                           (riece-make-identity target)
134                           riece-channel-buffer-alist))))
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                target))
165       "\n"))))
166
167 (defun riece-handle-ctcp-action-request (prefix target string)
168   (let ((buffer (if (riece-channel-p target)
169                     (cdr (riece-identity-assoc
170                           (riece-make-identity target)
171                           riece-channel-buffer-alist))))
172         (user (riece-prefix-nickname prefix)))
173     (riece-insert-change buffer (concat user " " string "\n"))
174     (riece-insert-change
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 user " " string)) "\n"))))
180
181 (defun riece-handle-ctcp-response (prefix string)
182   (when (and prefix string
183              (riece-prefix-nickname prefix))
184     (let* ((parameters (riece-split-parameters string))
185            (targets (split-string (car parameters) ","))
186            (message (nth 1 parameters)))
187       (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message)
188           (let ((response (downcase (match-string 1 message))))
189             (if (match-beginning 2)
190                 (setq message (substring (match-string 2 message) 1)))
191             (let ((hook
192                    (intern (concat "riece-ctcp-" response "-response-hook")))
193                   (function (intern-soft (concat "riece-handle-ctcp-"
194                                                  response "-response")))
195                   (after-hook
196                    (intern (concat "riece-ctcp-after-" response
197                                    "-response-hook"))))
198               (unless (condition-case error
199                           (run-hook-with-args-until-success
200                            hook prefix (car targets) message)
201                         (error
202                          (if riece-debug
203                              (message "Error occurred in `%S': %S" hook error))
204                          nil))
205                 (if function
206                     (condition-case error
207                         (funcall function prefix (car targets) message)
208                       (error
209                        (if riece-debug
210                            (message "Error occurred in `%S': %S"
211                                     function error))))))
212               (condition-case error
213                   (run-hook-with-args-until-success
214                    after-hook prefix (car targets) message)
215                 (error
216                  (if riece-debug
217                      (message "Error occurred in `%S': %S"
218                               after-hook error)))))
219             t)))))
220
221 (defun riece-handle-ctcp-version-response (prefix target string)
222   (riece-insert-change
223    (list riece-dialogue-buffer riece-others-buffer)
224    (concat
225     (riece-concat-server-name
226      (format "CTCP VERSION for %s (%s) = %s"
227              (riece-prefix-nickname prefix)
228              (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
229              string))
230     "\n")))
231
232 (defun riece-handle-ctcp-ping-response (prefix target string)
233   (let* ((now (current-time))
234          (elapsed (+ (* 65536 (- (car now) (car riece-ctcp-ping-time)))
235                      (- (nth 1 now) (nth 1 riece-ctcp-ping-time)))))
236     (riece-insert-change
237      (list riece-dialogue-buffer riece-others-buffer)
238      (concat
239       (riece-concat-server-name
240        (format "CTCP PING for %s (%s) = %d sec"
241                (riece-prefix-nickname prefix)
242                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
243                elapsed))
244       "\n"))))
245
246 (defun riece-handle-ctcp-clientinfo-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 CLIENTINFO 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-command-ctcp-version (user)
258   (interactive
259    (let ((completion-ignore-case t))
260      (list (completing-read
261             "Channel/User: "
262             (mapcar #'list (riece-get-users-on-server))))))
263   (riece-send-string (format "PRIVMSG %s :\1VERSION\1\r\n" user)))
264
265 (defun riece-command-ctcp-ping (user)
266   (interactive
267    (let ((completion-ignore-case t))
268      (list (completing-read
269             "Channel/User: "
270             (mapcar #'list (riece-get-users-on-server))))))
271   (riece-send-string (format "PRIVMSG %s :\1PING\1\r\n" user))
272   (setq riece-ctcp-ping-time (current-time)))
273
274 (defun riece-command-ctcp-clientinfo (user)
275   (interactive
276    (let ((completion-ignore-case t))
277      (list (completing-read
278             "Channel/User: "
279             (mapcar #'list (riece-get-users-on-server))))))
280   (riece-send-string (format "PRIVMSG %s :\1CLIENTINFO\1\r\n" user)))
281
282 (defun riece-command-ctcp-action (channel action)
283   (interactive
284    (list (if current-prefix-arg
285              (completing-read
286               "Channel/User: "
287               (mapcar #'list riece-current-channels))
288            riece-current-channel)
289          (read-string "Action: ")))
290   (if (equal action "")
291       (error "No action"))
292   (riece-send-string (format "PRIVMSG %s :\1ACTION %s\1\r\n"
293                              (riece-identity-prefix channel)
294                              action))
295   (let ((buffer (cdr (riece-identity-assoc
296                       (riece-make-identity channel)
297                       riece-channel-buffer-alist))))
298     (riece-insert-change
299      buffer
300      (concat (riece-identity-prefix (riece-current-nickname)) " " action "\n"))
301     (riece-insert-change
302      (if (and riece-channel-buffer-mode
303               (not (eq buffer riece-channel-buffer)))
304          (list riece-dialogue-buffer riece-others-buffer)
305        riece-dialogue-buffer)
306      (concat
307       (riece-concat-server-name
308        (concat (riece-identity-prefix (riece-current-nickname)) " " action))
309       "\n"))))
310
311 (provide 'riece-ctcp)
312
313 ;;; riece-ctcp.el ends here