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                     (cdr (riece-identity-assoc
  87                           (riece-make-identity target)
  88                           riece-channel-buffer-alist))))
  89         (user (riece-prefix-nickname prefix)))
  90     (riece-send-string
  91      (format "NOTICE %s :\1VERSION %s\1\r\n" user (riece-extended-version)))
  92     (riece-insert-change buffer (format "CTCP VERSION from %s\n" user))
  93     (riece-insert-change
  94      (if (and riece-channel-buffer-mode
  95               (not (eq buffer riece-channel-buffer)))
  96          (list riece-dialogue-buffer riece-others-buffer)
  97        riece-dialogue-buffer)
  98      (concat
  99       (riece-concat-server-name
 100        (format "CTCP VERSION from %s (%s) to %s"
 101                user
 102                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
 103                target))
 104       "\n"))))
 105
 106 (defun riece-handle-ctcp-ping-request (prefix target string)
 107   (let ((buffer (if (riece-channel-p target)
 108                     (cdr (riece-identity-assoc
 109                           (riece-make-identity target)
 110                           riece-channel-buffer-alist))))
 111         (user (riece-prefix-nickname prefix)))
 112     (riece-send-string
 113      (if string
 114          (format "NOTICE %s :\1PING %s\1\r\n" user string)
 115        (format "NOTICE %s :\1PING\1\r\n" user string)))
 116     (riece-insert-change buffer (format "CTCP PING from %s\n" user))
 117     (riece-insert-change
 118      (if (and riece-channel-buffer-mode
 119               (not (eq buffer riece-channel-buffer)))
 120          (list riece-dialogue-buffer riece-others-buffer)
 121        riece-dialogue-buffer)
 122      (concat
 123       (riece-concat-server-name
 124        (format "CTCP PING from %s (%s) to %s"
 125                user
 126                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
 127                target))
 128       "\n"))))
 129
 130 (defun riece-handle-ctcp-clientinfo-request (prefix target string)
 131   (let ((buffer (if (riece-channel-p target)
 132                     (cdr (riece-identity-assoc
 133                           (riece-make-identity target)
 134                           riece-channel-buffer-alist))))
 135         (user (riece-prefix-nickname prefix)))
 136     (riece-send-string
 137      (format "NOTICE %s :\1CLIENTINFO %s\1\r\n"
 138              user
 139              (let (messages)
 140                (mapatoms
 141                 (lambda (atom)
 142                   (let ((case-fold-search t))
 143                     (if (and (fboundp atom)
 144                              (string-match
 145                               "riece-handle-ctcp-\\(.+\\)-request"
 146                               (symbol-name atom)))
 147                         (setq messages
 148                               (cons (match-string 1 (symbol-name atom))
 149                                     messages))))))
 150                (mapconcat #'upcase (append messages
 151                                            riece-ctcp-additional-clientinfo)
 152                           " "))))
 153     (riece-insert-change buffer (format "CTCP CLIENTINFO from %s\n" user))
 154     (riece-insert-change
 155      (if (and riece-channel-buffer-mode
 156               (not (eq buffer riece-channel-buffer)))
 157          (list riece-dialogue-buffer riece-others-buffer)
 158        riece-dialogue-buffer)
 159      (concat
 160       (riece-concat-server-name
 161        (format "CTCP CLIENTINFO from %s (%s) to %s"
 162                user
 163                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
 164                target))
 165       "\n"))))
 166
 167 (defun riece-handle-ctcp-action-request (prefix target string)
 168   (let ((buffer (if (riece-channel-p target)
 169                     (cdr (riece-identity-assoc
 170                           (riece-make-identity target)
 171                           riece-channel-buffer-alist))))
 172         (user (riece-prefix-nickname prefix)))
 173     (riece-insert-change buffer (concat user " " string "\n"))
 174     (riece-insert-change
 175      (if (and riece-channel-buffer-mode
 176               (not (eq buffer riece-channel-buffer)))
 177          (list riece-dialogue-buffer riece-others-buffer)
 178        riece-dialogue-buffer)
 179      (concat (riece-concat-server-name (concat user " " string)) "\n"))))
 180
 181 (defun riece-handle-ctcp-response (prefix string)
 182   (when (and prefix string
 183              (riece-prefix-nickname prefix))
 184     (let* ((parameters (riece-split-parameters string))
 185            (targets (split-string (car parameters) ","))
 186            (message (nth 1 parameters)))
 187       (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message)
 188           (let ((response (downcase (match-string 1 message))))
 189             (if (match-beginning 2)
 190                 (setq message (substring (match-string 2 message) 1)))
 191             (let ((hook
 192                    (intern (concat "riece-ctcp-" response "-response-hook")))
 193                   (function (intern-soft (concat "riece-handle-ctcp-"
 194                                                  response "-response")))
 195                   (after-hook
 196                    (intern (concat "riece-ctcp-after-" response
 197                                    "-response-hook"))))
 198               (unless (condition-case error
 199                           (run-hook-with-args-until-success
 200                            hook prefix (car targets) message)
 201                         (error
 202                          (if riece-debug
 203                              (message "Error occurred in `%S': %S" hook error))
 204                          nil))
 205                 (if function
 206                     (condition-case error
 207                         (funcall function prefix (car targets) message)
 208                       (error
 209                        (if riece-debug
 210                            (message "Error occurred in `%S': %S"
 211                                     function error))))))
 212               (condition-case error
 213                   (run-hook-with-args-until-success
 214                    after-hook prefix (car targets) message)
 215                 (error
 216                  (if riece-debug
 217                      (message "Error occurred in `%S': %S"
 218                               after-hook error)))))
 219             t)))))
 220
 221 (defun riece-handle-ctcp-version-response (prefix target string)
 222   (riece-insert-change
 223    (list riece-dialogue-buffer riece-others-buffer)
 224    (concat
 225     (riece-concat-server-name
 226      (format "CTCP VERSION for %s (%s) = %s"
 227              (riece-prefix-nickname prefix)
 228              (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
 229              string))
 230     "\n")))
 231
 232 (defun riece-handle-ctcp-ping-response (prefix target string)
 233   (let* ((now (current-time))
 234          (elapsed (+ (* 65536 (- (car now) (car riece-ctcp-ping-time)))
 235                      (- (nth 1 now) (nth 1 riece-ctcp-ping-time)))))
 236     (riece-insert-change
 237      (list riece-dialogue-buffer riece-others-buffer)
 238      (concat
 239       (riece-concat-server-name
 240        (format "CTCP PING for %s (%s) = %d sec"
 241                (riece-prefix-nickname prefix)
 242                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
 243                elapsed))
 244       "\n"))))
 245
 246 (defun riece-handle-ctcp-clientinfo-response (prefix target string)
 247   (riece-insert-change
 248    (list riece-dialogue-buffer riece-others-buffer)
 249    (concat
 250     (riece-concat-server-name
 251      (format "CTCP CLIENTINFO for %s (%s) = %s"
 252              (riece-prefix-nickname prefix)
 253              (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
 254              string))
 255     "\n")))
 256
 257 (defun riece-command-ctcp-version (user)
 258   (interactive
 259    (let ((completion-ignore-case t))
 260      (list (completing-read
 261             "Channel/User: "
 262             (mapcar #'list (riece-get-users-on-server))))))
 263   (riece-send-string (format "PRIVMSG %s :\1VERSION\1\r\n" user)))
 264
 265 (defun riece-command-ctcp-ping (user)
 266   (interactive
 267    (let ((completion-ignore-case t))
 268      (list (completing-read
 269             "Channel/User: "
 270             (mapcar #'list (riece-get-users-on-server))))))
 271   (riece-send-string (format "PRIVMSG %s :\1PING\1\r\n" user))
 272   (setq riece-ctcp-ping-time (current-time)))
 273
 274 (defun riece-command-ctcp-clientinfo (user)
 275   (interactive
 276    (let ((completion-ignore-case t))
 277      (list (completing-read
 278             "Channel/User: "
 279             (mapcar #'list (riece-get-users-on-server))))))
 280   (riece-send-string (format "PRIVMSG %s :\1CLIENTINFO\1\r\n" user)))
 281
 282 (defun riece-command-ctcp-action (channel action)
 283   (interactive
 284    (list (if current-prefix-arg
 285              (completing-read
 286               "Channel/User: "
 287               (mapcar #'list riece-current-channels))
 288            riece-current-channel)
 289          (read-string "Action: ")))
 290   (if (equal action "")
 291       (error "No action"))
 292   (riece-send-string (format "PRIVMSG %s :\1ACTION %s\1\r\n"
 293                              (riece-identity-prefix channel)
 294                              action))
 295   (let ((buffer (cdr (riece-identity-assoc
 296                       (riece-make-identity channel)
 297                       riece-channel-buffer-alist))))
 298     (riece-insert-change
 299      buffer
 300      (concat (riece-identity-prefix (riece-current-nickname)) " " action "\n"))
 301     (riece-insert-change
 302      (if (and riece-channel-buffer-mode
 303               (not (eq buffer riece-channel-buffer)))
 304          (list riece-dialogue-buffer riece-others-buffer)
 305        riece-dialogue-buffer)
 306      (concat
 307       (riece-concat-server-name
 308        (concat (riece-identity-prefix (riece-current-nickname)) " " action))
 309       "\n"))))
 310
 311 (provide 'riece-ctcp)
 312
 313 ;;; riece-ctcp.el ends here