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-handle-ctcp-action-request (prefix target string)
 174   (let ((buffer (if (riece-channel-p target)
 175                     (riece-channel-buffer (riece-make-identity
 176                                            target riece-server-name))))
 177         (user (riece-prefix-nickname prefix)))
 178     (riece-insert buffer (concat riece-ctcp-action-prefix
 179                                  (riece-format-identity
 180                                   (riece-make-identity user riece-server-name)
 181                                   t)
 182                                  " " string
 183                                  "\n"))
 184     (riece-insert
 185      (if (and riece-channel-buffer-mode
 186               (not (eq buffer riece-channel-buffer)))
 187          (list riece-dialogue-buffer riece-others-buffer)
 188        riece-dialogue-buffer)
 189      (concat (riece-concat-server-name
 190               (concat riece-ctcp-action-prefix
 191                       (riece-format-identity
 192                        (riece-make-identity target riece-server-name)
 193                        t)
 194                       ": "
 195                       (riece-format-identity
 196                        (riece-make-identity user riece-server-name)
 197                        t)
 198                       " " string)) "\n"))))
 199
 200 (defun riece-handle-ctcp-time-request (prefix target string)
 201   (let* ((target-identity (riece-make-identity target riece-server-name))
 202          (buffer (if (riece-channel-p target)
 203                      (riece-channel-buffer target-identity)))
 204          (user (riece-prefix-nickname prefix))
 205          (time (format-time-string "%c")))
 206     (riece-send-string
 207      (format "NOTICE %s :\1TIME %s\1\r\n" user time))
 208     (riece-insert-change buffer (format (riece-mcat "CTCP TIME from %s\n")
 209                                         user))
 210     (riece-insert-change
 211      (if (and riece-channel-buffer-mode
 212               (not (eq buffer riece-channel-buffer)))
 213          (list riece-dialogue-buffer riece-others-buffer)
 214        riece-dialogue-buffer)
 215      (concat
 216       (riece-concat-server-name
 217        (format (riece-mcat "CTCP TIME from %s (%s) to %s")
 218                user
 219                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
 220                (riece-format-identity target-identity t)))
 221       "\n"))))
 222
 223 (defun riece-handle-ctcp-response (prefix string)
 224   (when (and (get 'riece-ctcp 'riece-addon-enabled) prefix string
 225              (riece-prefix-nickname prefix))
 226     (let* ((parameters (riece-split-parameters string))
 227            (targets (split-string (car parameters) ","))
 228            (message (nth 1 parameters)))
 229       (if (string-match "\1\\([^ ]+\\)\\( .+\\)?\1" message)
 230           (let ((response (downcase (match-string 1 message))))
 231             (if (match-beginning 2)
 232                 (setq message (substring (match-string 2 message) 1)))
 233             (let ((hook
 234                    (intern (concat "riece-ctcp-" response "-response-hook")))
 235                   (function (intern-soft (concat "riece-handle-ctcp-"
 236                                                  response "-response")))
 237                   (after-hook
 238                    (intern (concat "riece-ctcp-after-" response
 239                                    "-response-hook"))))
 240               (unless (riece-funcall-ignore-errors
 241                        (symbol-name hook)
 242                        #'run-hook-with-args-until-success
 243                        hook prefix (car targets) message)
 244                 (if function
 245                     (riece-funcall-ignore-errors
 246                      (symbol-name function)
 247                      function prefix (car targets) message))
 248                 (riece-funcall-ignore-errors (symbol-name after-hook)
 249                                              #'run-hook-with-args-until-success
 250                                              after-hook prefix (car targets)
 251                                              message)))
 252             t)))))
 253
 254 (defun riece-handle-ctcp-version-response (prefix target string)
 255   (riece-insert-change
 256    (list riece-dialogue-buffer riece-others-buffer)
 257    (concat
 258     (riece-concat-server-name
 259      (format (riece-mcat "CTCP VERSION for %s (%s) = %s")
 260              (riece-prefix-nickname prefix)
 261              (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
 262              string))
 263     "\n")))
 264
 265 (defun riece-handle-ctcp-ping-response (prefix target string)
 266   (let* ((now (current-time))
 267          (elapsed (+ (* 65536 (- (car now) (car riece-ctcp-ping-time)))
 268                      (- (nth 1 now) (nth 1 riece-ctcp-ping-time)))))
 269     (riece-insert-change
 270      (list riece-dialogue-buffer riece-others-buffer)
 271      (concat
 272       (riece-concat-server-name
 273        (format (riece-mcat "CTCP PING for %s (%s) = %d sec")
 274                (riece-prefix-nickname prefix)
 275                (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
 276                elapsed))
 277       "\n"))))
 278
 279 (defun riece-handle-ctcp-clientinfo-response (prefix target string)
 280   (riece-insert-change
 281    (list riece-dialogue-buffer riece-others-buffer)
 282    (concat
 283     (riece-concat-server-name
 284      (format (riece-mcat "CTCP CLIENTINFO for %s (%s) = %s")
 285              (riece-prefix-nickname prefix)
 286              (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
 287              string))
 288     "\n")))
 289
 290 (defun riece-handle-ctcp-time-response (prefix target string)
 291   (riece-insert-change
 292    (list riece-dialogue-buffer riece-others-buffer)
 293    (concat
 294     (riece-concat-server-name
 295      (format (riece-mcat "CTCP TIME for %s (%s) = %s")
 296              (riece-prefix-nickname prefix)
 297              (riece-strip-user-at-host (riece-prefix-user-at-host prefix))
 298              string))
 299     "\n")))
 300
 301 (defun riece-command-ctcp-version (target)
 302   (interactive
 303    (list (riece-completing-read-identity
 304           (riece-mcat "Channel/User: ")
 305           (riece-get-identities-on-server (riece-current-server-name)))))
 306   (riece-send-string (format "PRIVMSG %s :\1VERSION\1\r\n"
 307                              (riece-identity-prefix target))))
 308
 309 (defun riece-command-ctcp-ping (target)
 310   (interactive
 311    (list (riece-completing-read-identity
 312           (riece-mcat "Channel/User: ")
 313           (riece-get-identities-on-server (riece-current-server-name)))))
 314   (riece-send-string (format "PRIVMSG %s :\1PING\1\r\n"
 315                              (riece-identity-prefix target)))
 316   (setq riece-ctcp-ping-time (current-time)))
 317
 318 (defun riece-command-ctcp-clientinfo (target)
 319   (interactive
 320    (list (riece-completing-read-identity
 321           (riece-mcat "Channel/User: ")
 322           (riece-get-identities-on-server (riece-current-server-name)))))
 323   (riece-send-string (format "PRIVMSG %s :\1CLIENTINFO\1\r\n"
 324                              (riece-identity-prefix target))))
 325
 326 (defun riece-command-ctcp-action (target action)
 327   (interactive
 328    (list (if current-prefix-arg
 329              (riece-completing-read-identity
 330               (riece-mcat "Channel/User: ")
 331               (riece-get-identities-on-server (riece-current-server-name)))
 332            riece-current-channel)
 333          (let (message)
 334            (beginning-of-line)
 335            (setq message (buffer-substring (point)
 336                                            (progn (end-of-line) (point))))
 337            (if (equal message "")
 338                (read-string (riece-mcat "Action: "))
 339              (prog1 (read-from-minibuffer (riece-mcat "Action: ")
 340                                           (cons message 0))
 341                (let ((next-line-add-newlines t))
 342                  (next-line 1)))))))
 343   (if (equal action "")
 344       (error "No action"))
 345   (riece-send-string (format "PRIVMSG %s :\1ACTION %s\1\r\n"
 346                              (riece-identity-prefix target)
 347                              action))
 348   (let ((buffer (riece-channel-buffer target)))
 349     (riece-insert
 350      buffer
 351      (concat riece-ctcp-action-prefix
 352              (riece-identity-prefix (riece-current-nickname)) " " action "\n"))
 353     (riece-insert
 354      (if (and riece-channel-buffer-mode
 355               (not (eq buffer riece-channel-buffer)))
 356          (list riece-dialogue-buffer riece-others-buffer)
 357        riece-dialogue-buffer)
 358      (concat
 359       (riece-with-server-buffer (riece-identity-server target)
 360         (riece-concat-server-name
 361          (concat riece-ctcp-action-prefix
 362                  (riece-format-identity target t) ": "
 363                  (riece-identity-prefix (riece-current-nickname)) " " action)))
 364       "\n"))))
 365
 366 (defun riece-command-ctcp-time (target)
 367   (interactive
 368    (list (riece-completing-read-identity
 369           (riece-mcat "Channel/User: ")
 370           (riece-get-identities-on-server (riece-current-server-name)))))
 371   (riece-send-string (format "PRIVMSG %s :\1TIME\1\r\n"
 372                              (riece-identity-prefix target))))
 373
 374 (defun riece-ctcp-requires ()
 375   (if (memq 'riece-highlight riece-addons)
 376       '(riece-highlight)))
 377
 378 (defvar riece-ctcp-dialogue-font-lock-keywords
 379   (list (concat "^" riece-time-prefix-regexp "\\("
 380                 (regexp-quote riece-ctcp-action-prefix)
 381                 ".*\\)$")
 382         1 riece-ctcp-action-face t t))
 383
 384 (defun riece-ctcp-insinuate ()
 385   (add-hook 'riece-privmsg-hook 'riece-handle-ctcp-request)
 386   (add-hook 'riece-notice-hook 'riece-handle-ctcp-response)
 387   (if (memq 'riece-highlight riece-addons)
 388       (setq riece-dialogue-font-lock-keywords
 389             (cons riece-ctcp-dialogue-font-lock-keywords
 390                   riece-dialogue-font-lock-keywords))))
 391
 392 (defun riece-ctcp-uninstall ()
 393   (remove-hook 'riece-privmsg-hook 'riece-handle-ctcp-request)
 394   (remove-hook 'riece-notice-hook 'riece-handle-ctcp-response)
 395   (setq riece-dialogue-font-lock-keywords
 396         (delq riece-ctcp-dialogue-font-lock-keywords
 397               riece-dialogue-font-lock-keywords)))
 398
 399 (defun riece-ctcp-enable ()
 400   (define-key riece-dialogue-mode-map "\C-cv" 'riece-command-ctcp-version)
 401   (define-key riece-dialogue-mode-map "\C-cp" 'riece-command-ctcp-ping)
 402   (define-key riece-dialogue-mode-map "\C-ca" 'riece-command-ctcp-action)
 403   (define-key riece-dialogue-mode-map "\C-cc" 'riece-command-ctcp-clientinfo)
 404   (define-key riece-dialogue-mode-map "\C-ct" 'riece-command-ctcp-time))
 405
 406 (defun riece-ctcp-disable ()
 407   (define-key riece-dialogue-mode-map "\C-cv" nil)
 408   (define-key riece-dialogue-mode-map "\C-cp" nil)
 409   (define-key riece-dialogue-mode-map "\C-ca" nil)
 410   (define-key riece-dialogue-mode-map "\C-cc" nil)
 411   (define-key riece-dialogue-mode-map "\C-ct" nil))
 412
 413 (provide 'riece-ctcp)
 414
 415 ;;; riece-ctcp.el ends here