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 (defvar riece-ctcp-additional-clientinfo nil)
  32
  33 (defvar riece-dialogue-mode-map)
  34
  35 (defun riece-ctcp-insinuate ()
  36   (add-hook 'riece-privmsg-hook 'riece-handle-ctcp-request)
  37   (add-hook 'riece-notice-hook 'riece-handle-ctcp-response)
  38   (define-key riece-dialogue-mode-map "\C-cv" 'riece-command-ctcp-version)
  39   (define-key riece-dialogue-mode-map "\C-cp" 'riece-command-ctcp-ping)
  40   (define-key riece-dialogue-mode-map "\C-ca" 'riece-command-ctcp-action)
  41   (define-key riece-dialogue-mode-map "\C-cc" 'riece-command-ctcp-clientinfo))
  42
  43 (defun riece-handle-ctcp-request (prefix string)
  44   (when (and prefix string
  45              (riece-prefix-nickname prefix))
  46     (let* ((parameters (riece-split-parameters string))
  47            (targets (split-string (car parameters) ","))
  48            (message (nth 1 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             (let ((hook
  54                    (intern (concat "riece-ctcp-" request "-request-hook")))
  55                   (function
  56                    (intern-soft (concat "riece-handle-ctcp-" request
  57                                         "-request")))
  58                   (after-hook
  59                    (intern (concat "riece-ctcp-after-" request
  60                                    "-request-hook"))))
  61               (unless (condition-case error
  62                           (run-hook-with-args-until-success
  63                            hook prefix (car targets) message)
  64                         (error
  65                          (if riece-debug
  66                              (message "Error occurred in `%S': %S" hook error))
  67                          nil))
  68                 (if function
  69                     (condition-case error
  70                         (funcall function prefix (car targets) message)
  71                       (error
  72                        (if riece-debug
  73                            (message "Error occurred in `%S': %S"
  74                                     function error))))))
  75               (condition-case error
  76                   (run-hook-with-args-until-success
  77                    after-hook prefix (car targets) message)
  78                 (error
  79                  (if riece-debug
  80                      (message "Error occurred in `%S': %S"
  81                               after-hook error)))))
  82             t)))))
  83
  84 (defun riece-handle-ctcp-version-request (prefix target string)
  85   (let ((buffer (if (riece-channel-p target)
  86                     (riece-channel-buffer-name
  87                      (riece-make-identity target riece-server-name))))
  88         (user (riece-prefix-nickname prefix)))
  89     (riece-send-string
  90      (format "NOTICE %s :\1VERSION %s\1\r\n" user (riece-extended-version)))
  91     (riece-insert-change buffer (format "CTCP VERSION from %s\n" user))
  92     (riece-insert-change
  93      (if (and riece-channel-buffer-mode
  94               (not (eq buffer riece-channel-buffer)))
  95          (list riece-dialogue-buffer riece-others-buffer)
  96        riece-dialogue-buffer)
  97      (concat
  98       (riece-concat-server-name
  99        (format "CTCP VERSION from %s (%s) to %s"
 100                user
 101                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
 102                target))
 103       "\n"))))
 104
 105 (defun riece-handle-ctcp-ping-request (prefix target string)
 106   (let ((buffer (if (riece-channel-p target)
 107                     (riece-channel-buffer-name
 108                      (riece-make-identity target riece-server-name))))
 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-clientinfo-request (prefix target string)
 129   (let ((buffer (if (riece-channel-p target)
 130                     (riece-channel-buffer-name
 131                      (riece-make-identity target riece-server-name))))
 132         (user (riece-prefix-nickname prefix)))
 133     (riece-send-string
 134      (format "NOTICE %s :\1CLIENTINFO %s\1\r\n"
 135              user
 136              (let (messages)
 137                (mapatoms
 138                 (lambda (atom)
 139                   (let ((case-fold-search t))
 140                     (if (and (fboundp atom)
 141                              (string-match
 142                               "riece-handle-ctcp-\\(.+\\)-request"
 143                               (symbol-name atom)))
 144                         (setq messages
 145                               (cons (match-string 1 (symbol-name atom))
 146                                     messages))))))
 147                (mapconcat #'upcase (append messages
 148                                            riece-ctcp-additional-clientinfo)
 149                           " "))))
 150     (riece-insert-change buffer (format "CTCP CLIENTINFO from %s\n" user))
 151     (riece-insert-change
 152      (if (and riece-channel-buffer-mode
 153               (not (eq buffer riece-channel-buffer)))
 154          (list riece-dialogue-buffer riece-others-buffer)
 155        riece-dialogue-buffer)
 156      (concat
 157       (riece-concat-server-name
 158        (format "CTCP CLIENTINFO from %s (%s) to %s"
 159                user
 160                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
 161                target))
 162       "\n"))))
 163
 164 (defun riece-handle-ctcp-action-request (prefix target string)
 165   (let ((buffer (if (riece-channel-p target)
 166                     (riece-channel-buffer-name
 167                      (riece-make-identity target riece-server-name))))
 168         (user (riece-prefix-nickname prefix)))
 169     (riece-insert-change buffer (concat user " " string "\n"))
 170     (riece-insert-change
 171      (if (and riece-channel-buffer-mode
 172               (not (eq buffer riece-channel-buffer)))
 173          (list riece-dialogue-buffer riece-others-buffer)
 174        riece-dialogue-buffer)
 175      (concat (riece-concat-server-name (concat user " " string)) "\n"))))
 176
 177 (defun riece-handle-ctcp-response (prefix string)
 178   (when (and prefix string
 179              (riece-prefix-nickname prefix))
 180     (let* ((parameters (riece-split-parameters string))
 181            (targets (split-string (car parameters) ","))
 182            (message (nth 1 parameters)))
 183       (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message)
 184           (let ((response (downcase (match-string 1 message))))
 185             (if (match-beginning 2)
 186                 (setq message (substring (match-string 2 message) 1)))
 187             (let ((hook
 188                    (intern (concat "riece-ctcp-" response "-response-hook")))
 189                   (function (intern-soft (concat "riece-handle-ctcp-"
 190                                                  response "-response")))
 191                   (after-hook
 192                    (intern (concat "riece-ctcp-after-" response
 193                                    "-response-hook"))))
 194               (unless (condition-case error
 195                           (run-hook-with-args-until-success
 196                            hook prefix (car targets) message)
 197                         (error
 198                          (if riece-debug
 199                              (message "Error occurred in `%S': %S" hook error))
 200                          nil))
 201                 (if function
 202                     (condition-case error
 203                         (funcall function prefix (car targets) message)
 204                       (error
 205                        (if riece-debug
 206                            (message "Error occurred in `%S': %S"
 207                                     function error))))))
 208               (condition-case error
 209                   (run-hook-with-args-until-success
 210                    after-hook prefix (car targets) message)
 211                 (error
 212                  (if riece-debug
 213                      (message "Error occurred in `%S': %S"
 214                               after-hook error)))))
 215             t)))))
 216
 217 (defun riece-handle-ctcp-version-response (prefix target string)
 218   (riece-insert-change
 219    (list riece-dialogue-buffer riece-others-buffer)
 220    (concat
 221     (riece-concat-server-name
 222      (format "CTCP VERSION for %s (%s) = %s"
 223              (riece-prefix-nickname prefix)
 224              (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
 225              string))
 226     "\n")))
 227
 228 (defun riece-handle-ctcp-ping-response (prefix target string)
 229   (let* ((now (current-time))
 230          (elapsed (+ (* 65536 (- (car now) (car riece-ctcp-ping-time)))
 231                      (- (nth 1 now) (nth 1 riece-ctcp-ping-time)))))
 232     (riece-insert-change
 233      (list riece-dialogue-buffer riece-others-buffer)
 234      (concat
 235       (riece-concat-server-name
 236        (format "CTCP PING for %s (%s) = %d sec"
 237                (riece-prefix-nickname prefix)
 238                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
 239                elapsed))
 240       "\n"))))
 241
 242 (defun riece-handle-ctcp-clientinfo-response (prefix target string)
 243   (riece-insert-change
 244    (list riece-dialogue-buffer riece-others-buffer)
 245    (concat
 246     (riece-concat-server-name
 247      (format "CTCP CLIENTINFO for %s (%s) = %s"
 248              (riece-prefix-nickname prefix)
 249              (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
 250              string))
 251     "\n")))
 252
 253 (defun riece-command-ctcp-version (user)
 254   (interactive
 255    (let ((completion-ignore-case t))
 256      (list (completing-read
 257             "Channel/User: "
 258             (mapcar #'list (riece-get-users-on-server))))))
 259   (riece-send-string (format "PRIVMSG %s :\1VERSION\1\r\n" user)))
 260
 261 (defun riece-command-ctcp-ping (user)
 262   (interactive
 263    (let ((completion-ignore-case t))
 264      (list (completing-read
 265             "Channel/User: "
 266             (mapcar #'list (riece-get-users-on-server))))))
 267   (riece-send-string (format "PRIVMSG %s :\1PING\1\r\n" user))
 268   (setq riece-ctcp-ping-time (current-time)))
 269
 270 (defun riece-command-ctcp-clientinfo (user)
 271   (interactive
 272    (let ((completion-ignore-case t))
 273      (list (completing-read
 274             "Channel/User: "
 275             (mapcar #'list (riece-get-users-on-server))))))
 276   (riece-send-string (format "PRIVMSG %s :\1CLIENTINFO\1\r\n" user)))
 277
 278 (defun riece-command-ctcp-action (channel action)
 279   (interactive
 280    (list (if current-prefix-arg
 281              (completing-read
 282               "Channel/User: "
 283               (mapcar #'list riece-current-channels))
 284            riece-current-channel)
 285          (read-string "Action: ")))
 286   (if (equal action "")
 287       (error "No action"))
 288   (riece-send-string (format "PRIVMSG %s :\1ACTION %s\1\r\n"
 289                              (riece-identity-prefix channel)
 290                              action))
 291   (let ((buffer (riece-channel-buffer-name
 292                  (riece-make-identity channel riece-server-name))))
 293     (riece-insert-change
 294      buffer
 295      (concat (riece-identity-prefix (riece-current-nickname)) " " action "\n"))
 296     (riece-insert-change
 297      (if (and riece-channel-buffer-mode
 298               (not (eq buffer riece-channel-buffer)))
 299          (list riece-dialogue-buffer riece-others-buffer)
 300        riece-dialogue-buffer)
 301      (concat
 302       (riece-concat-server-name
 303        (concat (riece-identity-prefix (riece-current-nickname)) " " action))
 304       "\n"))))
 305
 306 (provide 'riece-ctcp)
 307
 308 ;;; riece-ctcp.el ends here