cgit.sxemacs.org Git - riece/blob - lisp/riece-ctcp.el

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