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