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