lisp/erc/erc-goodies.el

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