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