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