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