Fixed typo.
[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
31 (defface riece-ctcp-action-face
32   '((((class color)
33       (background dark))
34      (:foreground "PaleGreen" :italic t))
35     (((class color)
36       (background light))
37      (:foreground "ForestGreen" :italic t))
38     (t
39      (:bold t)))
40   "Face used for displaying \"*** Action:\" line"
41   :group 'riece-highlight-faces)
42 (defvar riece-ctcp-action-face 'riece-ctcp-action-face)
43
44 (defconst riece-ctcp-action-prefix "*** Action: ")
45
46 (defvar riece-ctcp-ping-time nil)
47 (defvar riece-ctcp-additional-clientinfo nil)
48
49 (defvar riece-dialogue-mode-map)
50
51 (defun riece-ctcp-requires ()
52   (if (memq 'riece-highlight riece-addons)
53       '(riece-highlight)))
54
55 (defun riece-ctcp-insinuate ()
56   (add-hook 'riece-privmsg-hook 'riece-handle-ctcp-request)
57   (add-hook 'riece-notice-hook 'riece-handle-ctcp-response)
58   (if (memq 'riece-highlight riece-addons)
59       (setq riece-dialogue-font-lock-keywords
60             (cons (list (concat "^" riece-time-prefix-regexp "\\("
61                                 (regexp-quote riece-ctcp-action-prefix)
62                                 ".*\\)$")
63                         1 riece-ctcp-action-face t t)
64                   riece-dialogue-font-lock-keywords)))
65   (define-key riece-dialogue-mode-map "\C-cv" 'riece-command-ctcp-version)
66   (define-key riece-dialogue-mode-map "\C-cp" 'riece-command-ctcp-ping)
67   (define-key riece-dialogue-mode-map "\C-ca" 'riece-command-ctcp-action)
68   (define-key riece-dialogue-mode-map "\C-cc" 'riece-command-ctcp-clientinfo))
69
70 (defun riece-handle-ctcp-request (prefix string)
71   (when (and prefix string
72              (riece-prefix-nickname prefix))
73     (let* ((parameters (riece-split-parameters string))
74            (targets (split-string (car parameters) ","))
75            (message (nth 1 parameters)))
76       (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message)
77           (let ((request (downcase (match-string 1 message))))
78             (if (match-beginning 2)
79                 (setq message (substring (match-string 2 message) 1)))
80             (let ((hook
81                    (intern (concat "riece-ctcp-" request "-request-hook")))
82                   (function
83                    (intern-soft (concat "riece-handle-ctcp-" request
84                                         "-request")))
85                   (after-hook
86                    (intern (concat "riece-ctcp-after-" request
87                                    "-request-hook"))))
88               (unless (condition-case error
89                           (run-hook-with-args-until-success
90                            hook prefix (car targets) message)
91                         (error
92                          (if riece-debug
93                              (message "Error in `%S': %S" hook error))
94                          nil))
95                 (if function
96                     (condition-case error
97                         (funcall function prefix (car targets) message)
98                       (error
99                        (if riece-debug
100                            (message "Error in `%S': %S"
101                                     function error))))))
102               (condition-case error
103                   (run-hook-with-args-until-success
104                    after-hook prefix (car targets) message)
105                 (error
106                  (if riece-debug
107                      (message "Error in `%S': %S"
108                               after-hook error)))))
109             t)))))
110
111 (defun riece-handle-ctcp-version-request (prefix target string)
112   (let* ((target-identity (riece-make-identity target riece-server-name))
113          (buffer (if (riece-channel-p target)
114                      (riece-channel-buffer target-identity)))
115          (user (riece-prefix-nickname prefix)))
116     (riece-send-string
117      (format "NOTICE %s :\1VERSION %s\1\r\n" user (riece-extended-version)))
118     (riece-insert-change buffer (format "CTCP VERSION 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 VERSION 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-ping-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      (if string
139          (format "NOTICE %s :\1PING %s\1\r\n" user string)
140        (format "NOTICE %s :\1PING\1\r\n" user string)))
141     (riece-insert-change buffer (format "CTCP PING from %s\n" user))
142     (riece-insert-change
143      (if (and riece-channel-buffer-mode
144               (not (eq buffer riece-channel-buffer)))
145          (list riece-dialogue-buffer riece-others-buffer)
146        riece-dialogue-buffer)
147      (concat
148       (riece-concat-server-name
149        (format "CTCP PING from %s (%s) to %s"
150                user
151                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
152                (riece-format-identity target-identity t)))
153       "\n"))))
154
155 (defun riece-handle-ctcp-clientinfo-request (prefix target string)
156   (let* ((target-identity (riece-make-identity target riece-server-name))
157          (buffer (if (riece-channel-p target)
158                      (riece-channel-buffer target-identity)))
159          (user (riece-prefix-nickname prefix)))
160     (riece-send-string
161      (format "NOTICE %s :\1CLIENTINFO %s\1\r\n"
162              user
163              (let (messages)
164                (mapatoms
165                 (lambda (atom)
166                   (let ((case-fold-search t))
167                     (if (and (fboundp atom)
168                              (string-match
169                               "riece-handle-ctcp-\\(.+\\)-request"
170                               (symbol-name atom)))
171                         (setq messages
172                               (cons (match-string 1 (symbol-name atom))
173                                     messages))))))
174                (mapconcat #'upcase (append messages
175                                            riece-ctcp-additional-clientinfo)
176                           " "))))
177     (riece-insert-change buffer (format "CTCP CLIENTINFO from %s\n" user))
178     (riece-insert-change
179      (if (and riece-channel-buffer-mode
180               (not (eq buffer riece-channel-buffer)))
181          (list riece-dialogue-buffer riece-others-buffer)
182        riece-dialogue-buffer)
183      (concat
184       (riece-concat-server-name
185        (format "CTCP CLIENTINFO from %s (%s) to %s"
186                user
187                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
188                (riece-format-identity target-identity t)))
189       "\n"))))
190
191 (defun riece-handle-ctcp-action-request (prefix target string)
192   (let ((buffer (if (riece-channel-p target)
193                     (riece-channel-buffer (riece-make-identity
194                                            target riece-server-name))))
195         (user (riece-prefix-nickname prefix)))
196     (riece-insert buffer (concat riece-ctcp-action-prefix user " " string
197                                  "\n"))
198     (riece-insert
199      (if (and riece-channel-buffer-mode
200               (not (eq buffer riece-channel-buffer)))
201          (list riece-dialogue-buffer riece-others-buffer)
202        riece-dialogue-buffer)
203      (concat (riece-concat-server-name (concat riece-ctcp-action-prefix user
204                                                " " string)) "\n"))))
205
206 (defun riece-handle-ctcp-response (prefix string)
207   (when (and prefix string
208              (riece-prefix-nickname prefix))
209     (let* ((parameters (riece-split-parameters string))
210            (targets (split-string (car parameters) ","))
211            (message (nth 1 parameters)))
212       (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message)
213           (let ((response (downcase (match-string 1 message))))
214             (if (match-beginning 2)
215                 (setq message (substring (match-string 2 message) 1)))
216             (let ((hook
217                    (intern (concat "riece-ctcp-" response "-response-hook")))
218                   (function (intern-soft (concat "riece-handle-ctcp-"
219                                                  response "-response")))
220                   (after-hook
221                    (intern (concat "riece-ctcp-after-" response
222                                    "-response-hook"))))
223               (unless (condition-case error
224                           (run-hook-with-args-until-success
225                            hook prefix (car targets) message)
226                         (error
227                          (if riece-debug
228                              (message "Error in `%S': %S" hook error))
229                          nil))
230                 (if function
231                     (condition-case error
232                         (funcall function prefix (car targets) message)
233                       (error
234                        (if riece-debug
235                            (message "Error in `%S': %S"
236                                     function error))))))
237               (condition-case error
238                   (run-hook-with-args-until-success
239                    after-hook prefix (car targets) message)
240                 (error
241                  (if riece-debug
242                      (message "Error in `%S': %S"
243                               after-hook error)))))
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-command-ctcp-version (target)
283   (interactive
284    (list (riece-completing-read-identity
285           "Channel/User: "
286           (riece-get-identities-on-server (riece-current-server-name)))))
287   (riece-send-string (format "PRIVMSG %s :\1VERSION\1\r\n"
288                              (riece-identity-prefix target))))
289
290 (defun riece-command-ctcp-ping (target)
291   (interactive
292    (list (riece-completing-read-identity
293           "Channel/User: "
294           (riece-get-identities-on-server (riece-current-server-name)))))
295   (riece-send-string (format "PRIVMSG %s :\1PING\1\r\n"
296                              (riece-identity-prefix target)))
297   (setq riece-ctcp-ping-time (current-time)))
298
299 (defun riece-command-ctcp-clientinfo (target)
300   (interactive
301    (list (riece-completing-read-identity
302           "Channel/User: "
303           (riece-get-identities-on-server (riece-current-server-name)))))
304   (riece-send-string (format "PRIVMSG %s :\1CLIENTINFO\1\r\n"
305                              (riece-identity-prefix target))))
306
307 (defun riece-command-ctcp-action (target action)
308   (interactive
309    (list (if current-prefix-arg
310              (riece-completing-read-identity
311               "Channel/User: "
312               (riece-get-identities-on-server (riece-current-server-name)))
313            riece-current-channel)
314          (let (message)
315            (beginning-of-line)
316            (setq message (buffer-substring (point)
317                                            (progn (end-of-line) (point))))
318            (if (equal message "")
319                (read-string "Action: ")
320              (prog1 (read-from-minibuffer "Action: " (cons message 0))
321                (let ((next-line-add-newlines t))
322                  (next-line 1)))))))
323   (if (equal action "")
324       (error "No action"))
325   (riece-send-string (format "PRIVMSG %s :\1ACTION %s\1\r\n"
326                              (riece-identity-prefix target)
327                              action))
328   (let ((buffer (riece-channel-buffer target)))
329     (riece-insert
330      buffer
331      (concat riece-ctcp-action-prefix
332              (riece-identity-prefix (riece-current-nickname)) " " action "\n"))
333     (riece-insert
334      (if (and riece-channel-buffer-mode
335               (not (eq buffer riece-channel-buffer)))
336          (list riece-dialogue-buffer riece-others-buffer)
337        riece-dialogue-buffer)
338      (concat
339       (riece-with-server-buffer (riece-identity-server target)
340         (riece-concat-server-name
341          (concat riece-ctcp-action-prefix
342                  (riece-identity-prefix (riece-current-nickname)) " " action
343                  " (in " (riece-format-identity target t) ")")))
344       "\n"))))
345
346 (provide 'riece-ctcp)
347
348 ;;; riece-ctcp.el ends here