-;;; riece-ctcp.el --- CTCP add-on
+;;; riece-ctcp.el --- CTCP (Client To Client Protocol) support
;; Copyright (C) 1998-2003 Daiki Ueno
;; Author: Daiki Ueno <ueno@unixuser.org>
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Commentary:
+
+;; NOTE: This is an add-on module for Riece.
;;; Code:
(defvar riece-dialogue-mode-map)
-(defvar riece-ctcp-enabled nil)
-
(defconst riece-ctcp-description
- "CTCP (Client To Client Protocol) support")
+ "CTCP (Client To Client Protocol) support.")
(defun riece-handle-ctcp-request (prefix string)
- (when (and riece-ctcp-enabled prefix string
+ (when (and (get 'riece-ctcp 'riece-addon-enabled) prefix string
(riece-prefix-nickname prefix))
(let* ((parameters (riece-split-parameters string))
(targets (split-string (car parameters) ","))
(after-hook
(intern (concat "riece-ctcp-after-" request
"-request-hook"))))
- (unless (riece-ignore-errors (symbol-name hook)
- (run-hook-with-args-until-success
- hook prefix (car targets) message))
+ (unless (riece-funcall-ignore-errors
+ (symbol-name hook)
+ #'run-hook-with-args-until-success
+ hook prefix (car targets) message)
(if function
(riece-funcall-ignore-errors (symbol-name function)
function prefix (car targets)
message))
- (riece-ignore-errors (symbol-name after-hook)
- (run-hook-with-args-until-success
- after-hook prefix (car targets) message))))
+ (riece-funcall-ignore-errors (symbol-name after-hook)
+ #'run-hook-with-args-until-success
+ after-hook prefix (car targets)
+ message)))
t)))))
(defun riece-handle-ctcp-version-request (prefix target string)
(riece-channel-buffer (riece-make-identity
target riece-server-name))))
(user (riece-prefix-nickname prefix)))
- (riece-insert buffer (concat riece-ctcp-action-prefix user " " string
+ (riece-insert buffer (concat riece-ctcp-action-prefix
+ (riece-format-identity
+ (riece-make-identity user riece-server-name)
+ t)
+ " " string
"\n"))
(riece-insert
(if (and riece-channel-buffer-mode
(not (eq buffer riece-channel-buffer)))
(list riece-dialogue-buffer riece-others-buffer)
riece-dialogue-buffer)
- (concat (riece-concat-server-name (concat riece-ctcp-action-prefix user
- " " string)) "\n"))))
+ (concat (riece-concat-server-name
+ (concat riece-ctcp-action-prefix
+ (riece-format-identity
+ (riece-make-identity target riece-server-name)
+ t)
+ ": "
+ (riece-format-identity
+ (riece-make-identity user riece-server-name)
+ t)
+ " " string)) "\n"))))
(defun riece-handle-ctcp-time-request (prefix target string)
(let* ((target-identity (riece-make-identity target riece-server-name))
"\n"))))
(defun riece-handle-ctcp-response (prefix string)
- (when (and riece-ctcp-enabled prefix string
+ (when (and (get 'riece-ctcp 'riece-addon-enabled) prefix string
(riece-prefix-nickname prefix))
(let* ((parameters (riece-split-parameters string))
(targets (split-string (car parameters) ","))
(after-hook
(intern (concat "riece-ctcp-after-" response
"-response-hook"))))
- (unless (riece-ignore-errors (symbol-name hook)
- (run-hook-with-args-until-success
- hook prefix (car targets) message))
+ (unless (riece-funcall-ignore-errors
+ (symbol-name hook)
+ #'run-hook-with-args-until-success
+ hook prefix (car targets) message)
(if function
(riece-funcall-ignore-errors
(symbol-name function)
function prefix (car targets) message))
- (riece-ignore-errors (symbol-name after-hook)
- (run-hook-with-args-until-success
- after-hook prefix (car targets) message))))
+ (riece-funcall-ignore-errors (symbol-name after-hook)
+ #'run-hook-with-args-until-success
+ after-hook prefix (car targets)
+ message)))
t)))))
(defun riece-handle-ctcp-version-response (prefix target string)
(riece-with-server-buffer (riece-identity-server target)
(riece-concat-server-name
(concat riece-ctcp-action-prefix
- (riece-identity-prefix (riece-current-nickname)) " " action
- " (in " (riece-format-identity target t) ")")))
+ (riece-format-identity target t) ": "
+ (riece-identity-prefix (riece-current-nickname)) " " action)))
"\n"))))
(defun riece-command-ctcp-time (target)
(if (memq 'riece-highlight riece-addons)
'(riece-highlight)))
+(defvar riece-ctcp-dialogue-font-lock-keywords
+ (list (concat "^" riece-time-prefix-regexp "\\("
+ (regexp-quote riece-ctcp-action-prefix)
+ ".*\\)$")
+ 1 riece-ctcp-action-face t t))
+
(defun riece-ctcp-insinuate ()
(add-hook 'riece-privmsg-hook 'riece-handle-ctcp-request)
(add-hook 'riece-notice-hook 'riece-handle-ctcp-response)
(if (memq 'riece-highlight riece-addons)
(setq riece-dialogue-font-lock-keywords
- (cons (list (concat "^" riece-time-prefix-regexp "\\("
- (regexp-quote riece-ctcp-action-prefix)
- ".*\\)$")
- 1 riece-ctcp-action-face t t)
+ (cons riece-ctcp-dialogue-font-lock-keywords
riece-dialogue-font-lock-keywords))))
+(defun riece-ctcp-uninstall ()
+ (remove-hook 'riece-privmsg-hook 'riece-handle-ctcp-request)
+ (remove-hook 'riece-notice-hook 'riece-handle-ctcp-response)
+ (setq riece-dialogue-font-lock-keywords
+ (delq riece-ctcp-dialogue-font-lock-keywords
+ riece-dialogue-font-lock-keywords)))
+
(defun riece-ctcp-enable ()
(define-key riece-dialogue-mode-map "\C-cv" 'riece-command-ctcp-version)
(define-key riece-dialogue-mode-map "\C-cp" 'riece-command-ctcp-ping)
(define-key riece-dialogue-mode-map "\C-ca" 'riece-command-ctcp-action)
(define-key riece-dialogue-mode-map "\C-cc" 'riece-command-ctcp-clientinfo)
- (define-key riece-dialogue-mode-map "\C-ct" 'riece-command-ctcp-time)
- (setq riece-ctcp-enabled t))
+ (define-key riece-dialogue-mode-map "\C-ct" 'riece-command-ctcp-time))
(defun riece-ctcp-disable ()
(define-key riece-dialogue-mode-map "\C-cv" nil)
(define-key riece-dialogue-mode-map "\C-cp" nil)
(define-key riece-dialogue-mode-map "\C-ca" nil)
(define-key riece-dialogue-mode-map "\C-cc" nil)
- (define-key riece-dialogue-mode-map "\C-ct" nil)
- (setq riece-ctcp-enabled nil))
+ (define-key riece-dialogue-mode-map "\C-ct" nil))
(provide 'riece-ctcp)
projects / riece / blobdiff