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