code.delx.au - gnu-emacs/blob - lisp/erc/erc-goodies.el

   1 ;; erc-goodies.el --- Collection of ERC modules
   2
   3 ;; Copyright (C) 2001-2012  Free Software Foundation, Inc.
   4
   5 ;; Author: Jorgen Schaefer <forcer@forcix.cx>
   6
   7 ;; Most code is taken verbatim from erc.el, see there for the original
   8 ;; authors.
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs 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 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; GNU Emacs 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 GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;; This provides some small but still useful modes for ERC.
  28
  29 ;;; Code:
  30
  31 (require 'erc)
  32
  33 ;;; Imenu support
  34
  35 (defun erc-imenu-setup ()
  36   "Setup Imenu support in an ERC buffer."
  37   (set (make-local-variable 'imenu-create-index-function)
  38        'erc-create-imenu-index))
  39
  40 (add-hook 'erc-mode-hook 'erc-imenu-setup)
  41 (autoload 'erc-create-imenu-index "erc-imenu" "Imenu index creation function")
  42
  43 ;;; Automatically scroll to bottom
  44 (defcustom erc-input-line-position nil
  45   "Specify where to position the input line when using `erc-scroll-to-bottom'.
  46
  47 This should be an integer specifying the line of the buffer on which
  48 the input line should stay.  A value of \"-1\" would keep the input
  49 line positioned on the last line in the buffer.  This is passed as an
  50 argument to `recenter'."
  51   :group 'erc-display
  52   :type '(choice integer (const nil)))
  53
  54 (define-erc-module scrolltobottom nil
  55   "This mode causes the prompt to stay at the end of the window."
  56   ((add-hook 'erc-mode-hook 'erc-add-scroll-to-bottom)
  57    (dolist (buffer (erc-buffer-list))
  58      (with-current-buffer buffer
  59        (erc-add-scroll-to-bottom))))
  60   ((remove-hook 'erc-mode-hook 'erc-add-scroll-to-bottom)
  61    (dolist (buffer (erc-buffer-list))
  62      (with-current-buffer buffer
  63        (remove-hook 'post-command-hook 'erc-scroll-to-bottom t)))))
  64
  65 (defun erc-add-scroll-to-bottom ()
  66   "A hook function for `erc-mode-hook' to recenter output at bottom of window.
  67
  68 If you find that ERC hangs when using this function, try customizing
  69 the value of `erc-input-line-position'.
  70
  71 This works whenever scrolling happens, so it's added to
  72 `window-scroll-functions' rather than `erc-insert-post-hook'."
  73   (add-hook 'post-command-hook 'erc-scroll-to-bottom nil t))
  74
  75 (defun erc-scroll-to-bottom ()
  76   "Recenter WINDOW so that `point' is on the last line.
  77
  78 This is added to `window-scroll-functions' by `erc-add-scroll-to-bottom'.
  79
  80 You can control which line is recentered to by customizing the
  81 variable `erc-input-line-position'."
  82       ;; Temporarily bind resize-mini-windows to nil so that users who have it
  83       ;; set to a non-nil value will not suffer from premature minibuffer
  84       ;; shrinkage due to the below recenter call.  I have no idea why this
  85       ;; works, but it solves the problem, and has no negative side effects.
  86       ;; (Fran Litterio, 2003/01/07)
  87   (let ((resize-mini-windows nil))
  88     (save-restriction
  89       (widen)
  90       (when (and erc-insert-marker
  91                  ;; we're editing a line. Scroll.
  92                  (> (point) erc-insert-marker))
  93         (save-excursion
  94           (goto-char (point-max))
  95           (recenter (or erc-input-line-position -1)))))))
  96
  97 ;;; Make read only
  98 (define-erc-module readonly nil
  99   "This mode causes all inserted text to be read-only."
 100   ((add-hook 'erc-insert-post-hook 'erc-make-read-only)
 101    (add-hook 'erc-send-post-hook 'erc-make-read-only))
 102   ((remove-hook 'erc-insert-post-hook 'erc-make-read-only)
 103    (remove-hook 'erc-send-post-hook 'erc-make-read-only)))
 104
 105 (defun erc-make-read-only ()
 106   "Make all the text in the current buffer read-only.
 107 Put this function on `erc-insert-post-hook' and/or `erc-send-post-hook'."
 108   (put-text-property (point-min) (point-max) 'read-only t)
 109   (put-text-property (point-min) (point-max) 'front-sticky t)
 110   (put-text-property (point-min) (point-max) 'rear-nonsticky t))
 111
 112 ;;; Move to prompt when typing text
 113 (define-erc-module move-to-prompt nil
 114   "This mode causes the point to be moved to the prompt when typing text."
 115   ((add-hook 'erc-mode-hook 'erc-move-to-prompt-setup)
 116    (dolist (buffer (erc-buffer-list))
 117      (with-current-buffer buffer
 118        (erc-move-to-prompt-setup))))
 119   ((remove-hook 'erc-mode-hook 'erc-move-to-prompt-setup)
 120    (dolist (buffer (erc-buffer-list))
 121      (with-current-buffer buffer
 122        (remove-hook 'pre-command-hook 'erc-move-to-prompt t)))))
 123
 124 (defun erc-move-to-prompt ()
 125   "Move the point to the ERC prompt if this is a self-inserting command."
 126   (when (and erc-input-marker (< (point) erc-input-marker)
 127              (eq 'self-insert-command this-command))
 128     (deactivate-mark)
 129     (push-mark)
 130     (goto-char (point-max))))
 131
 132 (defun erc-move-to-prompt-setup ()
 133   "Initialize the move-to-prompt module for XEmacs."
 134   (add-hook 'pre-command-hook 'erc-move-to-prompt nil t))
 135
 136 ;;; Keep place in unvisited channels
 137 (define-erc-module keep-place nil
 138   "Leave point above un-viewed text in other channels."
 139   ((add-hook 'erc-insert-pre-hook  'erc-keep-place))
 140   ((remove-hook 'erc-insert-pre-hook  'erc-keep-place)))
 141
 142 (defun erc-keep-place (ignored)
 143   "Move point away from the last line in a non-selected ERC buffer."
 144   (when (and (not (eq (window-buffer (selected-window))
 145                       (current-buffer)))
 146              (>= (point) erc-insert-marker))
 147     (deactivate-mark)
 148     (goto-char (erc-beg-of-input-line))
 149     (forward-line -1)))
 150
 151 ;;; Distinguish non-commands
 152 (defvar erc-noncommands-list '(erc-cmd-ME
 153                                erc-cmd-COUNTRY
 154                                erc-cmd-SV
 155                                erc-cmd-SM
 156                                erc-cmd-SMV
 157                                erc-cmd-LASTLOG)
 158   "List of commands that are aliases for CTCP ACTION or for ERC messages.
 159
 160 If a command's function symbol is in this list, the typed command
 161 does not appear in the ERC buffer after the user presses ENTER.")
 162
 163 (define-erc-module noncommands nil
 164   "This mode distinguishes non-commands.
 165 Commands listed in `erc-insert-this' know how to display
 166 themselves."
 167   ((add-hook 'erc-send-pre-hook 'erc-send-distinguish-noncommands))
 168   ((remove-hook 'erc-send-pre-hook 'erc-send-distinguish-noncommands)))
 169
 170 (defun erc-send-distinguish-noncommands (str)
 171   "If STR is an ERC non-command, set `erc-insert-this' to nil."
 172   (let* ((command (erc-extract-command-from-line str))
 173          (cmd-fun (and command
 174                        (car command))))
 175     (when (and cmd-fun
 176                (not (string-match "\n.+$" str))
 177                (memq cmd-fun erc-noncommands-list))
 178       (setq erc-insert-this nil))))
 179
 180 ;;; IRC control character processing.
 181 (defgroup erc-control-characters nil
 182   "Dealing with control characters."
 183   :group 'erc)
 184
 185 (defcustom erc-interpret-controls-p t
 186   "*If non-nil, display IRC colors and other highlighting effects.
 187
 188 If this is set to the symbol `remove', ERC removes all IRC colors and
 189 highlighting effects.  When this variable is non-nil, it can cause Emacs to run
 190 slowly on systems lacking sufficient CPU speed.  In chatty channels, or in an
 191 emergency (message flood) it can be turned off to save processing time.  See
 192 `erc-toggle-interpret-controls'."
 193   :group 'erc-control-characters
 194   :type '(choice (const :tag "Highlight control characters" t)
 195                  (const :tag "Remove control characters" remove)
 196                  (const :tag "Display raw control characters" nil)))
 197
 198 (defcustom erc-interpret-mirc-color nil
 199   "*If non-nil, ERC will interpret mIRC color codes."
 200   :group 'erc-control-characters
 201   :type 'boolean)
 202
 203 (defcustom erc-beep-p nil
 204   "Beep if C-g is in the server message.
 205 The value `erc-interpret-controls-p' must also be t for this to work."
 206   :group 'erc-control-characters
 207   :type 'boolean)
 208
 209 (defface erc-bold-face '((t (:bold t)))
 210   "ERC bold face."
 211   :group 'erc-faces)
 212 (defface erc-inverse-face
 213   '((t (:foreground "White" :background "Black")))
 214   "ERC inverse face."
 215   :group 'erc-faces)
 216 (defface erc-underline-face '((t (:underline t)))
 217   "ERC underline face."
 218   :group 'erc-faces)
 219
 220 (defface fg:erc-color-face0 '((t (:foreground "White")))
 221   "ERC face."
 222   :group 'erc-faces)
 223 (defface fg:erc-color-face1 '((t (:foreground "black")))
 224   "ERC face."
 225   :group 'erc-faces)
 226 (defface fg:erc-color-face2 '((t (:foreground "blue4")))
 227   "ERC face."
 228   :group 'erc-faces)
 229 (defface fg:erc-color-face3 '((t (:foreground "green4")))
 230   "ERC face."
 231   :group 'erc-faces)
 232 (defface fg:erc-color-face4 '((t (:foreground "red")))
 233   "ERC face."
 234   :group 'erc-faces)
 235 (defface fg:erc-color-face5 '((t (:foreground "brown")))
 236   "ERC face."
 237   :group 'erc-faces)
 238 (defface fg:erc-color-face6 '((t (:foreground "purple")))
 239   "ERC face."
 240   :group 'erc-faces)
 241 (defface fg:erc-color-face7 '((t (:foreground "orange")))
 242   "ERC face."
 243   :group 'erc-faces)
 244 (defface fg:erc-color-face8 '((t (:foreground "yellow")))
 245   "ERC face."
 246   :group 'erc-faces)
 247 (defface fg:erc-color-face9 '((t (:foreground "green")))
 248   "ERC face."
 249   :group 'erc-faces)
 250 (defface fg:erc-color-face10 '((t (:foreground "lightblue1")))
 251   "ERC face."
 252   :group 'erc-faces)
 253 (defface fg:erc-color-face11 '((t (:foreground "cyan")))
 254   "ERC face."
 255   :group 'erc-faces)
 256 (defface fg:erc-color-face12 '((t (:foreground "blue")))
 257   "ERC face."
 258   :group 'erc-faces)
 259 (defface fg:erc-color-face13 '((t (:foreground "deeppink")))
 260   "ERC face."
 261   :group 'erc-faces)
 262 (defface fg:erc-color-face14 '((t (:foreground "gray50")))
 263   "ERC face."
 264   :group 'erc-faces)
 265 (defface fg:erc-color-face15 '((t (:foreground "gray90")))
 266   "ERC face."
 267   :group 'erc-faces)
 268
 269 (defface bg:erc-color-face0 '((t (:background "White")))
 270   "ERC face."
 271   :group 'erc-faces)
 272 (defface bg:erc-color-face1 '((t (:background "black")))
 273   "ERC face."
 274   :group 'erc-faces)
 275 (defface bg:erc-color-face2 '((t (:background "blue4")))
 276   "ERC face."
 277   :group 'erc-faces)
 278 (defface bg:erc-color-face3 '((t (:background "green4")))
 279   "ERC face."
 280   :group 'erc-faces)
 281 (defface bg:erc-color-face4 '((t (:background "red")))
 282   "ERC face."
 283   :group 'erc-faces)
 284 (defface bg:erc-color-face5 '((t (:background "brown")))
 285   "ERC face."
 286   :group 'erc-faces)
 287 (defface bg:erc-color-face6 '((t (:background "purple")))
 288   "ERC face."
 289   :group 'erc-faces)
 290 (defface bg:erc-color-face7 '((t (:background "orange")))
 291   "ERC face."
 292   :group 'erc-faces)
 293 (defface bg:erc-color-face8 '((t (:background "yellow")))
 294   "ERC face."
 295   :group 'erc-faces)
 296 (defface bg:erc-color-face9 '((t (:background "green")))
 297   "ERC face."
 298   :group 'erc-faces)
 299 (defface bg:erc-color-face10 '((t (:background "lightblue1")))
 300   "ERC face."
 301   :group 'erc-faces)
 302 (defface bg:erc-color-face11 '((t (:background "cyan")))
 303   "ERC face."
 304   :group 'erc-faces)
 305 (defface bg:erc-color-face12 '((t (:background "blue")))
 306   "ERC face."
 307   :group 'erc-faces)
 308 (defface bg:erc-color-face13 '((t (:background "deeppink")))
 309   "ERC face."
 310   :group 'erc-faces)
 311 (defface bg:erc-color-face14 '((t (:background "gray50")))
 312   "ERC face."
 313   :group 'erc-faces)
 314 (defface bg:erc-color-face15 '((t (:background "gray90")))
 315   "ERC face."
 316   :group 'erc-faces)
 317
 318 (defun erc-get-bg-color-face (n)
 319   "Fetches the right face for background color N (0-15)."
 320   (if (stringp n) (setq n (string-to-number n)))
 321   (if (not (numberp n))
 322       (prog1 'default
 323         (erc-error "erc-get-bg-color-face: n is NaN: %S" n))
 324     (when (> n 16)
 325       (erc-log (format "   Wrong color: %s" n))
 326       (setq n (mod n 16)))
 327     (cond
 328      ((and (>= n 0) (< n 16))
 329       (intern (concat "bg:erc-color-face" (number-to-string n))))
 330      (t (erc-log (format "   Wrong color: %s" n)) 'default))))
 331
 332 (defun erc-get-fg-color-face (n)
 333   "Fetches the right face for foreground color N (0-15)."
 334   (if (stringp n) (setq n (string-to-number n)))
 335   (if (not (numberp n))
 336       (prog1 'default
 337         (erc-error "erc-get-fg-color-face: n is NaN: %S" n))
 338     (when (> n 16)
 339       (erc-log (format "   Wrong color: %s" n))
 340       (setq n (mod n 16)))
 341     (cond
 342      ((and (>= n 0) (< n 16))
 343       (intern (concat "fg:erc-color-face" (number-to-string n))))
 344      (t (erc-log (format "   Wrong color: %s" n)) 'default))))
 345
 346 (define-erc-module irccontrols nil
 347   "This mode enables the interpretation of IRC control chars."
 348   ((add-hook 'erc-insert-modify-hook 'erc-controls-highlight)
 349    (add-hook 'erc-send-modify-hook 'erc-controls-highlight))
 350   ((remove-hook 'erc-insert-modify-hook 'erc-controls-highlight)
 351    (remove-hook 'erc-send-modify-hook 'erc-controls-highlight)))
 352
 353 (defun erc-controls-interpret (str)
 354    "Return a copy of STR after dealing with IRC control characters.
 355 See `erc-interpret-controls-p' and `erc-interpret-mirc-color' for options."
 356    (when str
 357      (let ((s str))
 358        (cond ((eq erc-interpret-controls-p 'remove)
 359               (erc-controls-strip s))
 360              (erc-interpret-controls-p
 361               (let ((boldp nil)
 362                     (inversep nil)
 363                     (underlinep nil)
 364                     (fg nil)
 365                     (bg nil))
 366                 (while (string-match erc-controls-highlight-regexp s)
 367                   (let ((control (match-string 1 s))
 368                         (fg-color (match-string 2 s))
 369                         (bg-color (match-string 4 s))
 370                         (start (match-beginning 0))
 371                         (end (+ (match-beginning 0)
 372                                 (length (match-string 5 s)))))
 373                     (setq s (erc-replace-match-subexpression-in-string
 374                              "" s control 1 start))
 375                     (cond ((and erc-interpret-mirc-color (or fg-color bg-color))
 376                            (setq fg fg-color)
 377                            (setq bg bg-color))
 378                           ((string= control "\C-b")
 379                            (setq boldp (not boldp)))
 380                           ((string= control "\C-v")
 381                            (setq inversep (not inversep)))
 382                           ((string= control "\C-_")
 383                            (setq underlinep (not underlinep)))
 384                           ((string= control "\C-c")
 385                            (setq fg nil
 386                                  bg nil))
 387                           ((string= control "\C-g")
 388                            (when erc-beep-p
 389                              (ding)))
 390                           ((string= control "\C-o")
 391                            (setq boldp nil
 392                                  inversep nil
 393                                  underlinep nil
 394                                  fg nil
 395                                  bg nil))
 396                           (t nil))
 397                     (erc-controls-propertize
 398                      start end boldp inversep underlinep fg bg s)))
 399                 s))
 400              (t s)))))
 401
 402 (defun erc-controls-strip (str)
 403   "Return a copy of STR with all IRC control characters removed."
 404   (when str
 405     (let ((s str))
 406       (while (string-match erc-controls-remove-regexp s)
 407         (setq s (replace-match "" nil nil s)))
 408       s)))
 409
 410 (defvar erc-controls-remove-regexp
 411   "\C-b\\|\C-_\\|\C-v\\|\C-g\\|\C-o\\|\C-c[0-9]?[0-9]?\\(,[0-9][0-9]?\\)?"
 412   "Regular expression which matches control characters to remove.")
 413
 414 (defvar erc-controls-highlight-regexp
 415   (concat "\\(\C-b\\|\C-v\\|\C-_\\|\C-g\\|\C-o\\|"
 416           "\C-c\\([0-9][0-9]?\\)?\\(,\\([0-9][0-9]?\\)\\)?\\)"
 417           "\\([^\C-b\C-v\C-_\C-c\C-g\C-o\n]*\\)")
 418   "Regular expression which matches control chars and the text to highlight.")
 419
 420 (defun erc-controls-highlight ()
 421   "Highlight IRC control chars in the buffer.
 422 This is useful for `erc-insert-modify-hook' and `erc-send-modify-hook'.
 423 Also see `erc-interpret-controls-p' and `erc-interpret-mirc-color'."
 424   (goto-char (point-min))
 425   (cond ((eq erc-interpret-controls-p 'remove)
 426          (while (re-search-forward erc-controls-remove-regexp nil t)
 427            (replace-match "")))
 428         (erc-interpret-controls-p
 429          (let ((boldp nil)
 430                (inversep nil)
 431                (underlinep nil)
 432                (fg nil)
 433                (bg nil))
 434            (while (re-search-forward erc-controls-highlight-regexp nil t)
 435              (let ((control (match-string 1))
 436                    (fg-color (match-string 2))
 437                    (bg-color (match-string 4))
 438                    (start (match-beginning 0))
 439                    (end (+ (match-beginning 0) (length (match-string 5)))))
 440                (replace-match "" nil nil nil 1)
 441                (cond ((and erc-interpret-mirc-color (or fg-color bg-color))
 442                       (setq fg fg-color)
 443                       (setq bg bg-color))
 444                      ((string= control "\C-b")
 445                       (setq boldp (not boldp)))
 446                      ((string= control "\C-v")
 447                       (setq inversep (not inversep)))
 448                      ((string= control "\C-_")
 449                       (setq underlinep (not underlinep)))
 450                      ((string= control "\C-c")
 451                       (setq fg nil
 452                             bg nil))
 453                      ((string= control "\C-g")
 454                       (when erc-beep-p
 455                         (ding)))
 456                      ((string= control "\C-o")
 457                       (setq boldp nil
 458                             inversep nil
 459                             underlinep nil
 460                             fg nil
 461                             bg nil))
 462                      (t nil))
 463                (erc-controls-propertize start end
 464                                         boldp inversep underlinep fg bg)))))
 465         (t nil)))
 466
 467 (defun erc-controls-propertize (from to boldp inversep underlinep fg bg
 468                                      &optional str)
 469   "Prepend properties from IRC control characters between FROM and TO.
 470 If optional argument STR is provided, apply to STR, otherwise prepend properties
 471 to a region in the current buffer."
 472   (font-lock-prepend-text-property
 473    from
 474    to
 475    'face
 476    (append (if boldp
 477                '(erc-bold-face)
 478              nil)
 479            (if inversep
 480                '(erc-inverse-face)
 481              nil)
 482            (if underlinep
 483                '(erc-underline-face)
 484              nil)
 485            (if fg
 486                (list (erc-get-fg-color-face fg))
 487              nil)
 488            (if bg
 489                (list (erc-get-bg-color-face bg))
 490              nil))
 491    str)
 492   str)
 493
 494 (defun erc-toggle-interpret-controls (&optional arg)
 495   "Toggle interpretation of control sequences in messages.
 496
 497 If ARG is positive, interpretation is turned on.
 498 Else interpretation is turned off."
 499   (interactive "P")
 500   (cond ((and (numberp arg) (> arg 0))
 501          (setq erc-interpret-controls-p t))
 502         (arg (setq erc-interpret-controls-p nil))
 503         (t (setq erc-interpret-controls-p (not erc-interpret-controls-p))))
 504   (message "ERC color interpretation %s"
 505            (if erc-interpret-controls-p "ON" "OFF")))
 506
 507 ;; Smiley
 508 (define-erc-module smiley nil
 509   "This mode translates text-smileys such as :-) into pictures.
 510 This requires the function `smiley-region', which is defined in
 511 smiley.el, which is part of Gnus."
 512   ((add-hook 'erc-insert-modify-hook 'erc-smiley)
 513    (add-hook 'erc-send-modify-hook 'erc-smiley))
 514   ((remove-hook 'erc-insert-modify-hook 'erc-smiley)
 515    (remove-hook 'erc-send-modify-hook 'erc-smiley)))
 516
 517 (defun erc-smiley ()
 518   "Smilify a region.
 519 This function should be used with `erc-insert-modify-hook'."
 520   (when (fboundp 'smiley-region)
 521     (smiley-region (point-min) (point-max))))
 522
 523 ;; Unmorse
 524 (define-erc-module unmorse nil
 525   "This mode causes morse code in the current channel to be unmorsed."
 526   ((add-hook 'erc-insert-modify-hook 'erc-unmorse))
 527   ((remove-hook 'erc-insert-modify-hook 'erc-unmorse)))
 528
 529 (defun erc-unmorse ()
 530   "Unmorse some text.
 531 Add this to `erc-insert-modify-hook' if you happen to be on a
 532 channel that has weird people talking in morse to each other.
 533
 534 See also `unmorse-region'."
 535   (goto-char (point-min))
 536   (when (re-search-forward "[.-]+\\([.-]*/? *\\)+[.-]+/?" nil t)
 537     (save-restriction
 538       (narrow-to-region (match-beginning 0) (match-end 0))
 539       ;; Turn " / " into "  "
 540       (goto-char (point-min))
 541       (while (re-search-forward " / " nil t)
 542         (replace-match "  "))
 543       ;; Turn "/ " into "/"
 544       (goto-char (point-min))
 545       (while (re-search-forward "/ " nil t)
 546         (replace-match "/"))
 547       ;; Unmorse region
 548       (unmorse-region (point-min) (point-max)))))
 549
 550 ;;; erc-occur
 551 (defun erc-occur (string &optional proc)
 552   "Search for STRING in all buffers related to current server.
 553 If called interactively and prefix argument is given, search on all connected
 554 servers.  If called from a program, PROC specifies the server process."
 555   (interactive
 556    (list (read-string "Search for: ")
 557          (if current-prefix-arg
 558              nil erc-server-process)))
 559   (if (fboundp 'multi-occur)
 560       (multi-occur (erc-buffer-list nil proc) string)
 561     (error "`multi-occur' is not defined as a function")))
 562
 563 (provide 'erc-goodies)
 564
 565 ;;; erc-goodies.el ends here