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 (add-hook 'riece-privmsg-hook 'riece-handle-ctcp-request)
  33 (add-hook 'riece-notice-hook 'riece-handle-ctcp-response)
  34
  35 (defvar riece-dialogue-mode-map)
  36
  37 (eval-after-load "riece"
  38   '(progn
  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)))
  41
  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-"
  57                                                    request
  58                                                    "-request"))))
  59                 (if function
  60                     (condition-case error
  61                         (funcall function prefix (car targets) message)
  62                       (error
  63                        (if riece-debug
  64                            (message "Error occurred in `%S': %S"
  65                                     function error))))))
  66               (run-hook-with-args-until-success
  67                (intern (concat "riece-ctcp-after-" request "-request-hook"))
  68                prefix (car targets) message))
  69             t)))))
  70
  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)))
  77     (riece-send-string
  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))
  80     (riece-insert-change
  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)
  85      (concat
  86       (riece-concat-server-name
  87        (format "CTCP VERSION from %s (%s) to %s"
  88                user
  89                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
  90                target))
  91       "\n"))))
  92
  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)))
  99     (riece-send-string
 100      (if string
 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))
 104     (riece-insert-change
 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)
 109      (concat
 110       (riece-concat-server-name
 111        (format "CTCP PING from %s (%s) to %s"
 112                user
 113                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
 114                target))
 115       "\n"))))
 116
 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-"
 132                                                    response
 133                                                    "-response"))))
 134                 (if function
 135                     (condition-case error
 136                         (funcall function prefix (car targets) message)
 137                       (error
 138                        (if riece-debug
 139                            (message "Error occurred in `%S': %S"
 140                                     function error))))))
 141               (run-hook-with-args-until-success
 142                (intern (concat "riece-ctcp-after-" response "-response-hook"))
 143                prefix (car targets) message))
 144             t)))))
 145
 146 (defun riece-handle-ctcp-version-response (prefix target string)
 147   (riece-insert-change
 148    (list riece-dialogue-buffer riece-others-buffer)
 149    (concat
 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))
 154              string))
 155     "\n")))
 156
 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)))))
 161     (riece-insert-change
 162      (list riece-dialogue-buffer riece-others-buffer)
 163      (concat
 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))
 168                elapsed))
 169       "\n"))))
 170
 171 (defun riece-command-ctcp-version (user)
 172   (interactive
 173    (let ((completion-ignore-case t))
 174      (list (completing-read
 175             "Channel/User: "
 176             (mapcar #'list (riece-get-users-on-server))))))
 177   (riece-send-string (format "PRIVMSG %s :\1VERSION\1\r\n" user)))
 178
 179 (defun riece-command-ctcp-ping (user)
 180   (interactive
 181    (let ((completion-ignore-case t))
 182      (list (completing-read
 183             "Channel/User: "
 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)))
 187
 188 (provide 'riece-ctcp)
 189
 190 ;;; riece-ctcp.el ends here