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