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