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-highlight)
  30 (require 'riece-display)
  31
  32 (defface riece-ctcp-action-face
  33   '((((class color)
  34       (background dark))
  35      (:foreground "PaleGreen" :italic t))
  36     (((class color)
  37       (background light))
  38      (:foreground "ForestGreen" :italic t))
  39     (t
  40      (:bold t)))
  41   "Face used for displaying \"*** Action:\" line"
  42   :group 'riece-highlight-faces)
  43 (defvar riece-ctcp-action-face 'riece-ctcp-action-face)
  44
  45 (defconst riece-ctcp-action-prefix "*** Action: ")
  46
  47 (defvar riece-ctcp-ping-time nil)
  48 (defvar riece-ctcp-additional-clientinfo nil)
  49
  50 (defvar riece-dialogue-mode-map)
  51
  52 (defvar riece-ctcp-enabled nil)
  53
  54 (defconst riece-ctcp-description
  55   "CTCP (Client To Client Protocol) support")
  56
  57 (defun riece-handle-ctcp-request (prefix string)
  58   (when (and riece-ctcp-enabled prefix string
  59              (riece-prefix-nickname prefix))
  60     (let* ((parameters (riece-split-parameters string))
  61            (targets (split-string (car parameters) ","))
  62            (message (nth 1 parameters)))
  63       (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message)
  64           (let ((request (downcase (match-string 1 message))))
  65             (if (match-beginning 2)
  66                 (setq message (substring (match-string 2 message) 1)))
  67             (let ((hook
  68                    (intern (concat "riece-ctcp-" request "-request-hook")))
  69                   (function
  70                    (intern-soft (concat "riece-handle-ctcp-" request
  71                                         "-request")))
  72                   (after-hook
  73                    (intern (concat "riece-ctcp-after-" request
  74                                    "-request-hook"))))
  75               (unless (condition-case error
  76                           (run-hook-with-args-until-success
  77                            hook prefix (car targets) message)
  78                         (error
  79                          (if riece-debug
  80                              (message "Error in `%S': %S" hook error))
  81                          nil))
  82                 (if function
  83                     (condition-case error
  84                         (funcall function prefix (car targets) message)
  85                       (error
  86                        (if riece-debug
  87                            (message "Error in `%S': %S"
  88                                     function error))))))
  89               (condition-case error
  90                   (run-hook-with-args-until-success
  91                    after-hook prefix (car targets) message)
  92                 (error
  93                  (if riece-debug
  94                      (message "Error in `%S': %S"
  95                               after-hook error)))))
  96             t)))))
  97
  98 (defun riece-handle-ctcp-version-request (prefix target string)
  99   (let* ((target-identity (riece-make-identity target riece-server-name))
 100          (buffer (if (riece-channel-p target)
 101                      (riece-channel-buffer target-identity)))
 102          (user (riece-prefix-nickname prefix)))
 103     (riece-send-string
 104      (format "NOTICE %s :\1VERSION %s\1\r\n" user (riece-extended-version)))
 105     (riece-insert-change buffer (format "CTCP VERSION from %s\n" user))
 106     (riece-insert-change
 107      (if (and riece-channel-buffer-mode
 108               (not (eq buffer riece-channel-buffer)))
 109          (list riece-dialogue-buffer riece-others-buffer)
 110        riece-dialogue-buffer)
 111      (concat
 112       (riece-concat-server-name
 113        (format "CTCP VERSION from %s (%s) to %s"
 114                user
 115                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
 116                (riece-format-identity target-identity t)))
 117       "\n"))))
 118
 119 (defun riece-handle-ctcp-ping-request (prefix target string)
 120   (let* ((target-identity (riece-make-identity target riece-server-name))
 121          (buffer (if (riece-channel-p target)
 122                      (riece-channel-buffer target-identity)))
 123          (user (riece-prefix-nickname prefix)))
 124     (riece-send-string
 125      (if string
 126          (format "NOTICE %s :\1PING %s\1\r\n" user string)
 127        (format "NOTICE %s :\1PING\1\r\n" user string)))
 128     (riece-insert-change buffer (format "CTCP PING from %s\n" user))
 129     (riece-insert-change
 130      (if (and riece-channel-buffer-mode
 131               (not (eq buffer riece-channel-buffer)))
 132          (list riece-dialogue-buffer riece-others-buffer)
 133        riece-dialogue-buffer)
 134      (concat
 135       (riece-concat-server-name
 136        (format "CTCP PING from %s (%s) to %s"
 137                user
 138                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
 139                (riece-format-identity target-identity t)))
 140       "\n"))))
 141
 142 (defun riece-handle-ctcp-clientinfo-request (prefix target string)
 143   (let* ((target-identity (riece-make-identity target riece-server-name))
 144          (buffer (if (riece-channel-p target)
 145                      (riece-channel-buffer target-identity)))
 146          (user (riece-prefix-nickname prefix)))
 147     (riece-send-string
 148      (format "NOTICE %s :\1CLIENTINFO %s\1\r\n"
 149              user
 150              (let (messages)
 151                (mapatoms
 152                 (lambda (atom)
 153                   (let ((case-fold-search t))
 154                     (if (and (fboundp atom)
 155                              (string-match
 156                               "riece-handle-ctcp-\\(.+\\)-request"
 157                               (symbol-name atom)))
 158                         (setq messages
 159                               (cons (match-string 1 (symbol-name atom))
 160                                     messages))))))
 161                (mapconcat #'upcase (append messages
 162                                            riece-ctcp-additional-clientinfo)
 163                           " "))))
 164     (riece-insert-change buffer (format "CTCP CLIENTINFO from %s\n" user))
 165     (riece-insert-change
 166      (if (and riece-channel-buffer-mode
 167               (not (eq buffer riece-channel-buffer)))
 168          (list riece-dialogue-buffer riece-others-buffer)
 169        riece-dialogue-buffer)
 170      (concat
 171       (riece-concat-server-name
 172        (format "CTCP CLIENTINFO from %s (%s) to %s"
 173                user
 174                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
 175                (riece-format-identity target-identity t)))
 176       "\n"))))
 177
 178 (defun riece-handle-ctcp-action-request (prefix target string)
 179   (let ((buffer (if (riece-channel-p target)
 180                     (riece-channel-buffer (riece-make-identity
 181                                            target riece-server-name))))
 182         (user (riece-prefix-nickname prefix)))
 183     (riece-insert buffer (concat riece-ctcp-action-prefix user " " string
 184                                  "\n"))
 185     (riece-insert
 186      (if (and riece-channel-buffer-mode
 187               (not (eq buffer riece-channel-buffer)))
 188          (list riece-dialogue-buffer riece-others-buffer)
 189        riece-dialogue-buffer)
 190      (concat (riece-concat-server-name (concat riece-ctcp-action-prefix user
 191                                                " " string)) "\n"))))
 192
 193 (defun riece-handle-ctcp-response (prefix string)
 194   (when (and riece-ctcp-enabled prefix string
 195              (riece-prefix-nickname prefix))
 196     (let* ((parameters (riece-split-parameters string))
 197            (targets (split-string (car parameters) ","))
 198            (message (nth 1 parameters)))
 199       (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message)
 200           (let ((response (downcase (match-string 1 message))))
 201             (if (match-beginning 2)
 202                 (setq message (substring (match-string 2 message) 1)))
 203             (let ((hook
 204                    (intern (concat "riece-ctcp-" response "-response-hook")))
 205                   (function (intern-soft (concat "riece-handle-ctcp-"
 206                                                  response "-response")))
 207                   (after-hook
 208                    (intern (concat "riece-ctcp-after-" response
 209                                    "-response-hook"))))
 210               (unless (condition-case error
 211                           (run-hook-with-args-until-success
 212                            hook prefix (car targets) message)
 213                         (error
 214                          (if riece-debug
 215                              (message "Error in `%S': %S" hook error))
 216                          nil))
 217                 (if function
 218                     (condition-case error
 219                         (funcall function prefix (car targets) message)
 220                       (error
 221                        (if riece-debug
 222                            (message "Error in `%S': %S"
 223                                     function error))))))
 224               (condition-case error
 225                   (run-hook-with-args-until-success
 226                    after-hook prefix (car targets) message)
 227                 (error
 228                  (if riece-debug
 229                      (message "Error in `%S': %S"
 230                               after-hook error)))))
 231             t)))))
 232
 233 (defun riece-handle-ctcp-version-response (prefix target string)
 234   (riece-insert-change
 235    (list riece-dialogue-buffer riece-others-buffer)
 236    (concat
 237     (riece-concat-server-name
 238      (format "CTCP VERSION for %s (%s) = %s"
 239              (riece-prefix-nickname prefix)
 240              (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
 241              string))
 242     "\n")))
 243
 244 (defun riece-handle-ctcp-ping-response (prefix target string)
 245   (let* ((now (current-time))
 246          (elapsed (+ (* 65536 (- (car now) (car riece-ctcp-ping-time)))
 247                      (- (nth 1 now) (nth 1 riece-ctcp-ping-time)))))
 248     (riece-insert-change
 249      (list riece-dialogue-buffer riece-others-buffer)
 250      (concat
 251       (riece-concat-server-name
 252        (format "CTCP PING for %s (%s) = %d sec"
 253                (riece-prefix-nickname prefix)
 254                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
 255                elapsed))
 256       "\n"))))
 257
 258 (defun riece-handle-ctcp-clientinfo-response (prefix target string)
 259   (riece-insert-change
 260    (list riece-dialogue-buffer riece-others-buffer)
 261    (concat
 262     (riece-concat-server-name
 263      (format "CTCP CLIENTINFO for %s (%s) = %s"
 264              (riece-prefix-nickname prefix)
 265              (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
 266              string))
 267     "\n")))
 268
 269 (defun riece-command-ctcp-version (target)
 270   (interactive
 271    (list (riece-completing-read-identity
 272           "Channel/User: "
 273           (riece-get-identities-on-server (riece-current-server-name)))))
 274   (riece-send-string (format "PRIVMSG %s :\1VERSION\1\r\n"
 275                              (riece-identity-prefix target))))
 276
 277 (defun riece-command-ctcp-ping (target)
 278   (interactive
 279    (list (riece-completing-read-identity
 280           "Channel/User: "
 281           (riece-get-identities-on-server (riece-current-server-name)))))
 282   (riece-send-string (format "PRIVMSG %s :\1PING\1\r\n"
 283                              (riece-identity-prefix target)))
 284   (setq riece-ctcp-ping-time (current-time)))
 285
 286 (defun riece-command-ctcp-clientinfo (target)
 287   (interactive
 288    (list (riece-completing-read-identity
 289           "Channel/User: "
 290           (riece-get-identities-on-server (riece-current-server-name)))))
 291   (riece-send-string (format "PRIVMSG %s :\1CLIENTINFO\1\r\n"
 292                              (riece-identity-prefix target))))
 293
 294 (defun riece-command-ctcp-action (target action)
 295   (interactive
 296    (list (if current-prefix-arg
 297              (riece-completing-read-identity
 298               "Channel/User: "
 299               (riece-get-identities-on-server (riece-current-server-name)))
 300            riece-current-channel)
 301          (let (message)
 302            (beginning-of-line)
 303            (setq message (buffer-substring (point)
 304                                            (progn (end-of-line) (point))))
 305            (if (equal message "")
 306                (read-string "Action: ")
 307              (prog1 (read-from-minibuffer "Action: " (cons message 0))
 308                (let ((next-line-add-newlines t))
 309                  (next-line 1)))))))
 310   (if (equal action "")
 311       (error "No action"))
 312   (riece-send-string (format "PRIVMSG %s :\1ACTION %s\1\r\n"
 313                              (riece-identity-prefix target)
 314                              action))
 315   (let ((buffer (riece-channel-buffer target)))
 316     (riece-insert
 317      buffer
 318      (concat riece-ctcp-action-prefix
 319              (riece-identity-prefix (riece-current-nickname)) " " action "\n"))
 320     (riece-insert
 321      (if (and riece-channel-buffer-mode
 322               (not (eq buffer riece-channel-buffer)))
 323          (list riece-dialogue-buffer riece-others-buffer)
 324        riece-dialogue-buffer)
 325      (concat
 326       (riece-with-server-buffer (riece-identity-server target)
 327         (riece-concat-server-name
 328          (concat riece-ctcp-action-prefix
 329                  (riece-identity-prefix (riece-current-nickname)) " " action
 330                  " (in " (riece-format-identity target t) ")")))
 331       "\n"))))
 332
 333 (defun riece-ctcp-requires ()
 334   (if (memq 'riece-highlight riece-addons)
 335       '(riece-highlight)))
 336
 337 (defun riece-ctcp-insinuate ()
 338   (add-hook 'riece-privmsg-hook 'riece-handle-ctcp-request)
 339   (add-hook 'riece-notice-hook 'riece-handle-ctcp-response)
 340   (if (memq 'riece-highlight riece-addons)
 341       (setq riece-dialogue-font-lock-keywords
 342             (cons (list (concat "^" riece-time-prefix-regexp "\\("
 343                                 (regexp-quote riece-ctcp-action-prefix)
 344                                 ".*\\)$")
 345                         1 riece-ctcp-action-face t t)
 346                   riece-dialogue-font-lock-keywords))))
 347
 348 (defun riece-ctcp-enable ()
 349   (define-key riece-dialogue-mode-map "\C-cv" 'riece-command-ctcp-version)
 350   (define-key riece-dialogue-mode-map "\C-cp" 'riece-command-ctcp-ping)
 351   (define-key riece-dialogue-mode-map "\C-ca" 'riece-command-ctcp-action)
 352   (define-key riece-dialogue-mode-map "\C-cc" 'riece-command-ctcp-clientinfo)
 353   (setq riece-ctcp-enabled t))
 354
 355 (defun riece-ctcp-disable ()
 356   (define-key riece-dialogue-mode-map "\C-cv" nil)
 357   (define-key riece-dialogue-mode-map "\C-cp" nil)
 358   (define-key riece-dialogue-mode-map "\C-ca" nil)
 359   (define-key riece-dialogue-mode-map "\C-cc" nil)
 360   (setq riece-ctcp-enabled nil))
 361
 362 (provide 'riece-ctcp)
 363
 364 ;;; riece-ctcp.el ends here