cgit.sxemacs.org Git - riece/blob - 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 (car parameters) ","))
  46            (message (nth 1 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 (car parameters) ","))
 121            (message (nth 1 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