1 ;;; riece-ctcp.el --- CTCP add-on
2 ;; Copyright (C) 1998-2003 Daiki Ueno
4 ;; Author: Daiki Ueno <ueno@unixuser.org>
6 ;; Keywords: IRC, riece
8 ;; This file is part of Riece.
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)
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.
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.
27 (require 'riece-version)
30 (defvar riece-ctcp-ping-time nil)
32 (add-hook 'riece-privmsg-hook 'riece-handle-ctcp-request)
33 (add-hook 'riece-notice-hook 'riece-handle-ctcp-response)
35 (defvar riece-dialogue-mode-map)
37 (eval-after-load "riece"
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)))
42 (defun riece-handle-ctcp-request (prefix string)
43 (when (and prefix string
44 (riece-prefix-nickname prefix))
45 (let* ((user (riece-prefix-nickname prefix))
46 (parameters (riece-split-parameters string))
47 (targets (split-string (pop parameters) ","))
48 (message (pop 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 (unless (run-hook-with-args-until-success
54 (intern (concat "riece-ctcp-" request "-request-hook"))
55 prefix (car targets) message)
56 (let ((function (intern-soft (concat "riece-handle-ctcp-"
61 (funcall function prefix (car targets) message)
64 (message "Error occurred in `%S': %S"
66 (run-hook-with-args-until-success
67 (intern (concat "riece-ctcp-after-" request "-request-hook"))
68 prefix (car targets) message))
71 (defun riece-handle-ctcp-version-request (prefix target string)
72 (let ((buffer (if (riece-channel-p target)
73 (cdr (riece-identity-assoc-no-server
74 (riece-make-identity target)
75 riece-channel-buffer-alist))))
76 (user (riece-prefix-nickname prefix)))
78 (format "NOTICE %s :\1VERSION %s\1\r\n" user (riece-extended-version)))
79 (riece-insert-change buffer (format "CTCP VERSION from %s\n" user))
81 (if (and riece-channel-buffer-mode
82 (not (eq buffer riece-channel-buffer)))
83 (list riece-dialogue-buffer riece-others-buffer)
84 riece-dialogue-buffer)
86 (riece-concat-server-name
87 (format "CTCP VERSION from %s (%s) to %s"
89 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
93 (defun riece-handle-ctcp-ping-request (prefix target string)
94 (let ((buffer (if (riece-channel-p target)
95 (cdr (riece-identity-assoc-no-server
96 (riece-make-identity target)
97 riece-channel-buffer-alist))))
98 (user (riece-prefix-nickname prefix)))
101 (format "NOTICE %s :\1PING %s\1\r\n" user string)
102 (format "NOTICE %s :\1PING\1\r\n" user string)))
103 (riece-insert-change buffer (format "CTCP PING from %s\n" user))
105 (if (and riece-channel-buffer-mode
106 (not (eq buffer riece-channel-buffer)))
107 (list riece-dialogue-buffer riece-others-buffer)
108 riece-dialogue-buffer)
110 (riece-concat-server-name
111 (format "CTCP PING from %s (%s) to %s"
113 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
117 (defun riece-handle-ctcp-response (prefix string)
118 (when (and prefix string
119 (riece-prefix-nickname prefix))
120 (let* ((user (riece-prefix-nickname prefix))
121 (parameters (riece-split-parameters string))
122 (targets (split-string (pop parameters) ","))
123 (message (pop parameters)))
124 (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message)
125 (let ((response (downcase (match-string 1 message))))
126 (if (match-beginning 2)
127 (setq message (substring (match-string 2 message) 1)))
128 (unless (run-hook-with-args-until-success
129 (intern (concat "riece-ctcp-" response "-response-hook"))
130 prefix (car targets) message)
131 (let ((function (intern-soft (concat "riece-handle-ctcp-"
135 (condition-case error
136 (funcall function prefix (car targets) message)
139 (message "Error occurred in `%S': %S"
141 (run-hook-with-args-until-success
142 (intern (concat "riece-ctcp-after-" response "-response-hook"))
143 prefix (car targets) message))
146 (defun riece-handle-ctcp-version-response (prefix target string)
148 (list riece-dialogue-buffer riece-others-buffer)
150 (riece-concat-server-name
151 (format "CTCP VERSION for %s (%s) = %s"
152 (riece-prefix-nickname prefix)
153 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
157 (defun riece-handle-ctcp-ping-response (prefix target string)
158 (let* ((now (current-time))
159 (elapsed (+ (* 65536 (- (car now) (car riece-ctcp-ping-time)))
160 (- (nth 1 now) (nth 1 riece-ctcp-ping-time)))))
162 (list riece-dialogue-buffer riece-others-buffer)
164 (riece-concat-server-name
165 (format "CTCP PING for %s (%s) = %d sec"
166 (riece-prefix-nickname prefix)
167 (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
171 (defun riece-command-ctcp-version (user)
173 (let ((completion-ignore-case t))
174 (list (completing-read
176 (mapcar #'list (riece-get-users-on-server))))))
177 (riece-send-string (format "PRIVMSG %s :\1VERSION\1\r\n" user)))
179 (defun riece-command-ctcp-ping (user)
181 (let ((completion-ignore-case t))
182 (list (completing-read
184 (mapcar #'list (riece-get-users-on-server))))))
185 (riece-send-string (format "PRIVMSG %s :\1PING\1\r\n" user))
186 (setq riece-ctcp-ping-time (current-time)))
188 (provide 'riece-ctcp)
190 ;;; riece-ctcp.el ends here