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