cgit.sxemacs.org Git - packages/blob - xemacs-packages/zenirc/src/zenirc-color.el

   1 ;;; zenirc-color.el --- color messages in zenirc
   2
   3 ;; Copyright (C) 1996 John Wiegley
   4 ;; Copyright (C) 1996, 1998 Per Persson
   5
   6 ;; Author: John Wiegley <johnw@borland.com>
   7 ;;         Per Persson <pp@sno.pp.se>
   8 ;; Maintainer: pp@sno.pp.se
   9 ;; Keywords: zenirc,extensions
  10 ;; Created: 1996-05-22
  11
  12 ;; This program is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16 ;;
  17 ;; This program is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21 ;;
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with this program; if not, you can either send email to this
  24 ;; program's maintainer or write to: The Free Software Foundation,
  25 ;; Inc.; 675 Massachusetts Avenue; Cambridge, MA 02139, USA.
  26
  27 ;;; Commentary:
  28
  29 ;;; This ZenIRC extensions allows you to colorize input from specific
  30 ;;; sources.  Use the "/color #victim <COLOR>" command to start
  31 ;;; colorizing a certain victim's output.
  32
  33 ;;; Code:
  34
  35 (require 'zenirc)
  36
  37 (defun zenirc-color-install-message-catalogs ()
  38   (zenirc-lang-define-catalog 'english
  39    '((color-lame-args . "[info] %s: not enough arguments.")
  40      (color-nonexistant . "[info] %s is not an allowed color.")
  41      (color-not-found . "[info] %s: not found in color list."))))
  42
  43 (defvar zenirc-color-mode nil
  44   "*If non-nil, then color messages fitting `zenirc-color-message-categories'.
  45 This is buffer-local.")
  46 (make-variable-buffer-local 'zenirc-color-mode)
  47
  48 (defvar zenirc-color-region-function 'zenirc-colorize-region
  49   "*Function to use for coloring.")
  50
  51 (defvar zenirc-facename-index 1
  52   "Used for creating new zenirc face names")
  53
  54 (defvar zenirc-color-alist
  55   '()
  56   "*A list of elements, each of which is (REGEXP FACE), where both are
  57 strings.  Any string containing REGEXP in the output will have it's face
  58 property set to FACE.")
  59 (make-variable-buffer-local 'zenirc-color-alist)
  60
  61 (defvar zenirc-color-message-categories
  62   '(privmsg privmsg_you notice notice_you ctcp_action)
  63   "*ZenIRC message categories to color.  This should be a list
  64 consisting of symbols corresponding to the type of messages in the
  65 message catalog which should be colored.  For example, private
  66 messages (`privmsg') and notices (`notice') are good choices.
  67
  68 If this variable is set to `t', then all messages are colored.
  69 If this variable is set to `nil', then no messages are colored.")
  70 (make-variable-buffer-local 'zenirc-color-message-categories)
  71
  72 (defvar zenirc-color-nonstandard-message-categories-p nil
  73   "If non-nil, then color messages that are not in a standard category.
  74 That is, color messages which did not originate from the message catalog,
  75 and thus have no category symbol.")
  76 (make-variable-buffer-local 'zenirc-color-nonstandard-message-categories-p)
  77
  78 ;; Check whether a given color really exists as a color.
  79 (defun zenirc-color-name-p (color)
  80   (let ((version (emacs-version)))
  81     (cond ((string-match "XEmacs" version)
  82            (valid-color-name-p color))
  83           ((string-match "GNU" version)
  84            (x-color-defined-p color))
  85           (t
  86            nil))))
  87 \f
  88 (defun zenirc-color-mode (&optional prefix)
  89   "Enable or disable colorization of irc messages.
  90
  91 A negative prefix argument disables this mode.
  92 No argument or any non-negative argument enables it.
  93
  94 The user may also enable or disable this mode simply by setting the
  95 variable of the same name."
  96   (interactive "P")
  97   (cond
  98    ((null prefix)
  99     (setq zenirc-color-mode (not zenirc-color-mode)))
 100    ((>= (prefix-numeric-value prefix) 0)
 101     (setq zenirc-color-mode t))
 102    (t
 103     (setq zenirc-color-mode nil)))
 104   (cond ((not (interactive-p)))
 105         (zenirc-color-mode
 106          (message "zenirc-color-mode is enabled"))
 107         (t
 108          (message "zenirc-color-mode is disabled")))
 109   zenirc-color-mode)
 110
 111 (defvar zenirc-face nil)
 112
 113 (defun zenirc-colorize-region (beg end)
 114   (interactive "r")
 115   (save-match-data
 116     (save-excursion
 117       (goto-char beg)
 118       (mapcar
 119        (function
 120         (lambda (elem)
 121           (if (re-search-forward (car elem) end t)
 122               (put-text-property beg end 'face (car (cdr elem))))))
 123        zenirc-color-alist))))
 124
 125 (defun zenirc-color-message (proc sym string)
 126   (and zenirc-color-mode
 127        (cond ((eq zenirc-color-message-categories t))
 128              ((null sym)
 129               zenirc-color-nonstandard-message-categories-p)
 130              ((memq sym zenirc-color-message-categories))
 131              (t nil))
 132        (funcall zenirc-color-region-function (point-min) (- (point-max) 1))))
 133
 134 \f
 135 (defvar zenirc-command-color-hook '(zenirc-command-color))
 136
 137 ;; /color #victim <color>
 138 (defun zenirc-command-color (proc cmd)
 139   (let* ((arg (zenirc-parse-firstword (cdr parsedcmd)))
 140          (victim (format "%s" (car arg)))
 141          (color (cdr arg)))
 142     (if (or (string= "" victim)
 143             (string= "" color))
 144         (zenirc-message proc 'color-lame-args "/color")
 145       (if (zenirc-color-name-p color)
 146           (let ((newface (make-symbol
 147                           (concat "zenirc-color-face-"
 148                                   (number-to-string zenirc-facename-index)))))
 149             (setq zenirc-facename-index (1+ zenirc-facename-index))
 150             (copy-face 'default newface)
 151             (set-face-foreground newface color)
 152             (setq zenirc-color-alist
 153                   (cons (list victim newface)
 154                         zenirc-color-alist)))
 155         (zenirc-message proc 'color-nonexistant color)))))
 156 \f
 157 (defvar zenirc-command-uncolor-hook '(zenirc-command-uncolor))
 158
 159 ;; /uncolor #victim
 160 (defun zenirc-command-uncolor (proc cmd)
 161   (let* ((arg (zenirc-parse-firstword (cdr parsedcmd)))
 162          (victim (format "%s" (car arg))))
 163     (if (string= "" victim)
 164         (zenirc-message proc 'color-lame-args "/uncolor"))
 165     (let ((pointer zenirc-color-alist) last found)
 166       (while pointer
 167         (if (string= (car (car pointer)) victim)
 168             (progn
 169               (setq found t)
 170               (if (= (length zenirc-color-alist) 1)
 171                   (setq zenirc-color-alist nil)
 172                 (if last
 173                     (setcdr last (cdr pointer))
 174                   (setq zenirc-color-alist (cdr pointer))))))
 175         (setq last pointer)
 176         (setq pointer (cdr pointer)))
 177       (if (not found)
 178           (zenirc-message proc 'color-not-found victim)))))
 179 \f
 180 (provide 'zenirc-color)
 181
 182 (zenirc-add-hook 'zenirc-message-hook 'zenirc-color-message)
 183
 184 (or (assq 'zenirc-color-mode minor-mode-alist)
 185     (setq minor-mode-alist
 186           (cons (list 'zenirc-color-mode " Zcolor") minor-mode-alist)))
 187
 188 (zenirc-color-install-message-catalogs)
 189
 190 ;;; zenirc-color.el ends here