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