51fc3465f25ad0904fc4add3ee297b2bbfaa06ba
[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
32 (defvar riece-dialogue-mode-map)
33
34 (defun riece-ctcp-insinuate ()
35   (add-hook 'riece-privmsg-hook 'riece-handle-ctcp-request)
36   (add-hook 'riece-notice-hook 'riece-handle-ctcp-response)
37   (define-key riece-dialogue-mode-map "\C-cv" 'riece-command-ctcp-version)
38   (define-key riece-dialogue-mode-map "\C-cp" 'riece-command-ctcp-ping))
39
40 (defun riece-handle-ctcp-request (prefix string)
41   (when (and prefix string
42              (riece-prefix-nickname prefix))
43     (let* ((user (riece-prefix-nickname prefix))
44            (parameters (riece-split-parameters string))
45            (targets (split-string (pop parameters) ","))
46            (message (pop parameters)))
47       (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message)
48           (let ((request (downcase (match-string 1 message))))
49             (if (match-beginning 2)
50                 (setq message (substring (match-string 2 message) 1)))
51             (unless (run-hook-with-args-until-success
52                      (intern (concat "riece-ctcp-" request "-request-hook"))
53                      prefix (car targets) message)
54               (let ((function (intern-soft (concat "riece-handle-ctcp-"
55                                                    request
56                                                    "-request"))))
57                 (if function
58                     (condition-case error
59                         (funcall function prefix (car targets) message)
60                       (error
61                        (if riece-debug
62                            (message "Error occurred in `%S': %S"
63                                     function error))))))
64               (run-hook-with-args-until-success
65                (intern (concat "riece-ctcp-after-" request "-request-hook"))
66                prefix (car targets) message))
67             t)))))
68
69 (defun riece-handle-ctcp-version-request (prefix target string)
70   (let ((buffer (if (riece-channel-p target)
71                     (cdr (riece-identity-assoc-no-server
72                           (riece-make-identity target)
73                           riece-channel-buffer-alist))))
74         (user (riece-prefix-nickname prefix)))
75     (riece-send-string
76      (format "NOTICE %s :\1VERSION %s\1\r\n" user (riece-extended-version)))
77     (riece-insert-change buffer (format "CTCP VERSION from %s\n" user))
78     (riece-insert-change
79      (if (and riece-channel-buffer-mode
80               (not (eq buffer riece-channel-buffer)))
81          (list riece-dialogue-buffer riece-others-buffer)
82        riece-dialogue-buffer)
83      (concat
84       (riece-concat-server-name
85        (format "CTCP VERSION from %s (%s) to %s"
86                user
87                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
88                target))
89       "\n"))))
90
91 (defun riece-handle-ctcp-ping-request (prefix target string)
92   (let ((buffer (if (riece-channel-p target)
93                     (cdr (riece-identity-assoc-no-server
94                           (riece-make-identity target)
95                           riece-channel-buffer-alist))))
96         (user (riece-prefix-nickname prefix)))
97     (riece-send-string
98      (if string
99          (format "NOTICE %s :\1PING %s\1\r\n" user string)
100        (format "NOTICE %s :\1PING\1\r\n" user string)))
101     (riece-insert-change buffer (format "CTCP PING from %s\n" user))
102     (riece-insert-change
103      (if (and riece-channel-buffer-mode
104               (not (eq buffer riece-channel-buffer)))
105          (list riece-dialogue-buffer riece-others-buffer)
106        riece-dialogue-buffer)
107      (concat
108       (riece-concat-server-name
109        (format "CTCP PING from %s (%s) to %s"
110                user
111                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
112                target))
113       "\n"))))
114
115 (defun riece-handle-ctcp-response (prefix string)
116   (when (and prefix string
117              (riece-prefix-nickname prefix))
118     (let* ((user (riece-prefix-nickname prefix))
119            (parameters (riece-split-parameters string))
120            (targets (split-string (pop parameters) ","))
121            (message (pop parameters)))
122       (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message)
123           (let ((response (downcase (match-string 1 message))))
124             (if (match-beginning 2)
125                 (setq message (substring (match-string 2 message) 1)))
126             (unless (run-hook-with-args-until-success
127                      (intern (concat "riece-ctcp-" response "-response-hook"))
128                      prefix (car targets) message)
129               (let ((function (intern-soft (concat "riece-handle-ctcp-"
130                                                    response
131                                                    "-response"))))
132                 (if function
133                     (condition-case error
134                         (funcall function prefix (car targets) message)
135                       (error
136                        (if riece-debug
137                            (message "Error occurred in `%S': %S"
138                                     function error))))))
139               (run-hook-with-args-until-success
140                (intern (concat "riece-ctcp-after-" response "-response-hook"))
141                prefix (car targets) message))
142             t)))))
143
144 (defun riece-handle-ctcp-version-response (prefix target string)
145   (riece-insert-change
146    (list riece-dialogue-buffer riece-others-buffer)
147    (concat
148     (riece-concat-server-name
149      (format "CTCP VERSION for %s (%s) = %s"
150              (riece-prefix-nickname prefix)
151              (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
152              string))
153     "\n")))
154
155 (defun riece-handle-ctcp-ping-response (prefix target string)
156   (let* ((now (current-time))
157          (elapsed (+ (* 65536 (- (car now) (car riece-ctcp-ping-time)))
158                      (- (nth 1 now) (nth 1 riece-ctcp-ping-time)))))
159     (riece-insert-change
160      (list riece-dialogue-buffer riece-others-buffer)
161      (concat
162       (riece-concat-server-name
163        (format "CTCP PING for %s (%s) = %d sec"
164                (riece-prefix-nickname prefix)
165                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
166                elapsed))
167       "\n"))))
168
169 (defun riece-command-ctcp-version (user)
170   (interactive
171    (let ((completion-ignore-case t))
172      (list (completing-read
173             "Channel/User: "
174             (mapcar #'list (riece-get-users-on-server))))))
175   (riece-send-string (format "PRIVMSG %s :\1VERSION\1\r\n" user)))
176
177 (defun riece-command-ctcp-ping (user)
178   (interactive
179    (let ((completion-ignore-case t))
180      (list (completing-read
181             "Channel/User: "
182             (mapcar #'list (riece-get-users-on-server))))))
183   (riece-send-string (format "PRIVMSG %s :\1PING\1\r\n" user))
184   (setq riece-ctcp-ping-time (current-time)))
185
186 (provide 'riece-ctcp)
187
188 ;;; riece-ctcp.el ends here