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