(match): Use yellow background on light-bg terminals.
[emacs.git] / lisp / erc / erc-match.el
blob50e4cfbc5218f8d80ec207a0cc00ca42c884fd6f
1 ;;; erc-match.el --- Highlight messages matching certain regexps
3 ;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
5 ;; Author: Andreas Fuchs <asf@void.at>
6 ;; Keywords: comm, faces
7 ;; URL: http://www.emacswiki.org/cgi-bin/wiki.pl?ErcMatch
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 2, or (at your option)
14 ;; any later version.
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24 ;; Boston, MA 02110-1301, USA.
26 ;;; Commentary:
28 ;; This file includes stuff to work with pattern matching in ERC. If
29 ;; you were used to customizing erc-fools, erc-keywords, erc-pals,
30 ;; erc-dangerous-hosts and the like, this file contains these
31 ;; customizable variables.
33 ;; Usage:
34 ;; Put (erc-match-mode 1) into your ~/.emacs file.
36 ;;; Code:
38 (require 'erc)
39 (eval-when-compile (require 'cl))
41 ;; Customisation:
43 (defgroup erc-match nil
44 "Keyword and Friend/Foe/... recognition.
45 Group containing all things concerning pattern matching in ERC
46 messages."
47 :group 'erc)
49 ;;;###autoload (autoload 'erc-match-mode "erc-match")
50 (define-erc-module match nil
51 "This mode checks whether messages match certain patterns. If so,
52 they are hidden or highlighted. This is controlled via the variables
53 `erc-pals', `erc-fools', `erc-keywords', `erc-dangerous-hosts', and
54 `erc-current-nick-highlight-type'. For all these highlighting types,
55 you can decide whether the entire message or only the sending nick is
56 highlighted."
57 ((add-hook 'erc-insert-modify-hook 'erc-match-message 'append))
58 ((remove-hook 'erc-insert-modify-hook 'erc-match-message)))
60 ;; Remaining customizations
62 (defcustom erc-pals nil
63 "List of pals on IRC."
64 :group 'erc-match
65 :type '(repeat regexp))
67 (defcustom erc-fools nil
68 "List of fools on IRC."
69 :group 'erc-match
70 :type '(repeat regexp))
72 (defcustom erc-keywords nil
73 "List of keywords to highlight in all incoming messages.
74 Each entry in the list is either a regexp, or a cons cell with the
75 regexp in the car and the face to use in the cdr. If no face is
76 specified, `erc-keyword-face' is used."
77 :group 'erc-match
78 :type '(repeat (choice regexp
79 (list regexp face))))
81 (defcustom erc-dangerous-hosts nil
82 "List of regexps for hosts to highlight.
83 Useful to mark nicks from dangerous hosts."
84 :group 'erc-match
85 :type '(repeat regexp))
87 (defcustom erc-current-nick-highlight-type 'keyword
88 "*Determines how to highlight text in which your current nickname appears
89 \(does not apply to text sent by you\).
91 The following values are allowed:
93 nil - do not highlight the message at all
94 'keyword - highlight all instances of current nickname in message
95 'nick - highlight the nick of the user who typed your nickname
96 'nick-or-keyword - highlight the nick of the user who typed your nickname,
97 or all instances of the current nickname if there was
98 no sending user
99 'all - highlight the entire message where current nickname occurs
101 Any other value disables highlighting of current nickname altogether."
102 :group 'erc-match
103 :type '(choice (const nil)
104 (const nick)
105 (const keyword)
106 (const nick-or-keyword)
107 (const all)))
109 (defcustom erc-pal-highlight-type 'nick
110 "*Determines how to highlight messages by pals.
111 See `erc-pals'.
113 The following values are allowed:
115 nil - do not highlight the message at all
116 'nick - highlight pal's nickname only
117 'all - highlight the entire message from pal
119 Any other value disables pal highlighting altogether."
120 :group 'erc-match
121 :type '(choice (const nil)
122 (const nick)
123 (const all)))
125 (defcustom erc-fool-highlight-type 'nick
126 "*Determines how to highlight messages by fools.
127 See `erc-fools'.
129 The following values are allowed:
131 nil - do not highlight the message at all
132 'nick - highlight fool's nickname only
133 'all - highlight the entire message from fool
135 Any other value disables fool highlighting altogether."
136 :group 'erc-match
137 :type '(choice (const nil)
138 (const nick)
139 (const all)))
141 (defcustom erc-keyword-highlight-type 'keyword
142 "*Determines how to highlight messages containing keywords.
143 See variable `erc-keywords'.
145 The following values are allowed:
147 'keyword - highlight keyword only
148 'all - highlight the entire message containing keyword
150 Any other value disables keyword highlighting altogether."
151 :group 'erc-match
152 :type '(choice (const nil)
153 (const keyword)
154 (const all)))
156 (defcustom erc-dangerous-host-highlight-type 'nick
157 "*Determines how to highlight messages by nicks from dangerous-hosts.
158 See `erc-dangerous-hosts'.
160 The following values are allowed:
162 'nick - highlight nick from dangerous-host only
163 'all - highlight the entire message from dangerous-host
165 Any other value disables dangerous-host highlighting altogether."
166 :group 'erc-match
167 :type '(choice (const nil)
168 (const nick)
169 (const all)))
172 (defcustom erc-log-matches-types-alist '((keyword . "ERC Keywords"))
173 "Alist telling ERC where to log which match types.
174 Valid match type keys are:
175 - keyword
176 - pal
177 - dangerous-host
178 - fool
179 - current-nick
181 The other element of each cons pair in this list is the buffer name to
182 use for the logged message."
183 :group 'erc-match
184 :type '(repeat (cons (choice :tag "Key"
185 (const keyword)
186 (const pal)
187 (const dangerous-host)
188 (const fool)
189 (const current-nick))
190 (string :tag "Buffer name"))))
192 (defcustom erc-log-matches-flag 'away
193 "Flag specifying when matched message logging should happen.
194 When nil, don't log any matched messages.
195 When t, log messages.
196 When 'away, log messages only when away."
197 :group 'erc-match
198 :type '(choice (const nil)
199 (const away)
200 (const t)))
202 (defcustom erc-log-match-format "%t<%n:%c> %m"
203 "Format for matched Messages.
204 This variable specifies how messages in the corresponding log buffers will
205 be formatted. The various format specs are:
207 %t Timestamp (uses `erc-timestamp-format' if non-nil or \"[%Y-%m-%d %H:%M] \")
208 %n Nickname of sender
209 %u Nickname!user@host of sender
210 %c Channel in which this was received
211 %m Message"
212 :group 'erc-match
213 :type 'string)
215 (defcustom erc-beep-match-types '(current-nick)
216 "Types of matches to beep for when a match occurs.
217 The function `erc-beep-on-match' needs to be added to `erc-text-matched-hook'
218 for beeping to work."
219 :group 'erc-match
220 :type '(choice (repeat :tag "Beep on match" (choice
221 (const current-nick)
222 (const keyword)
223 (const pal)
224 (const dangerous-host)
225 (const fool)))
226 (const :tag "Don't beep" nil)))
228 (defcustom erc-text-matched-hook '(erc-log-matches)
229 "Hook run when text matches a given match-type.
230 Functions in this hook are passed as arguments:
231 \(match-type nick!user@host message) where MATCH-TYPE is a symbol of:
232 current-nick, keyword, pal, dangerous-host, fool"
233 :options '(erc-log-matches erc-hide-fools erc-beep-on-match)
234 :group 'erc-match
235 :type 'hook)
237 ;; Internal variables:
239 ;; This is exactly the same as erc-button-syntax-table. Should we
240 ;; just put it in erc.el
241 (defvar erc-match-syntax-table
242 (let ((table (make-syntax-table)))
243 (modify-syntax-entry ?\( "w" table)
244 (modify-syntax-entry ?\) "w" table)
245 (modify-syntax-entry ?\[ "w" table)
246 (modify-syntax-entry ?\] "w" table)
247 (modify-syntax-entry ?\{ "w" table)
248 (modify-syntax-entry ?\} "w" table)
249 (modify-syntax-entry ?` "w" table)
250 (modify-syntax-entry ?' "w" table)
251 (modify-syntax-entry ?^ "w" table)
252 (modify-syntax-entry ?- "w" table)
253 (modify-syntax-entry ?_ "w" table)
254 (modify-syntax-entry ?| "w" table)
255 (modify-syntax-entry ?\\ "w" table)
256 table)
257 "Syntax table used when highlighting messages.
258 This syntax table should make all the legal nick characters word
259 constituents.")
261 ;; Faces:
263 (defface erc-current-nick-face '((t (:bold t :foreground "DarkTurquoise")))
264 "ERC face for occurrences of your current nickname."
265 :group 'erc-faces)
267 (defface erc-dangerous-host-face '((t (:foreground "red")))
268 "ERC face for people on dangerous hosts.
269 See `erc-dangerous-hosts'."
270 :group 'erc-faces)
272 (defface erc-pal-face '((t (:bold t :foreground "Magenta")))
273 "ERC face for your pals.
274 See `erc-pals'."
275 :group 'erc-faces)
277 (defface erc-fool-face '((t (:foreground "dim gray")))
278 "ERC face for fools on the channel.
279 See `erc-fools'."
280 :group 'erc-faces)
282 (defface erc-keyword-face '((t (:bold t :foreground "pale green")))
283 "ERC face for your keywords.
284 Note that this is the default face to use if
285 `erc-keywords' does not specify another."
286 :group 'erc-faces)
288 ;; Functions:
290 (defun erc-add-entry-to-list (list prompt &optional completions)
291 "Add an entry interactively to a list.
292 LIST must be passed as a symbol
293 The query happens using PROMPT.
294 Completion is performed on the optional alist COMPLETIONS."
295 (let ((entry (completing-read
296 prompt
297 completions
298 (lambda (x)
299 (not (erc-member-ignore-case (car x) (symbol-value list)))))))
300 (if (erc-member-ignore-case entry (symbol-value list))
301 (error (format "\"%s\" is already on the list" entry))
302 (set list (cons entry (symbol-value list))))))
304 (defun erc-remove-entry-from-list (list prompt)
305 "Remove an entry interactively from a list.
306 LIST must be passed as a symbol.
307 The elements of LIST can be strings, or cons cells where the
308 car is the string."
309 (let* ((alist (mapcar (lambda (x)
310 (if (listp x)
312 (list x)))
313 (symbol-value list)))
314 (entry (completing-read
315 prompt
316 alist
318 t)))
319 (if (erc-member-ignore-case entry (symbol-value list))
320 ;; plain string
321 (set list (delete entry (symbol-value list)))
322 ;; cons cell
323 (set list (delete (assoc entry (symbol-value list))
324 (symbol-value list))))))
326 ;;;###autoload
327 (defun erc-add-pal ()
328 "Add pal interactively to `erc-pals'."
329 (interactive)
330 (erc-add-entry-to-list 'erc-pals "Add pal: " (erc-get-server-nickname-alist)))
332 ;;;###autoload
333 (defun erc-delete-pal ()
334 "Delete pal interactively to `erc-pals'."
335 (interactive)
336 (erc-remove-entry-from-list 'erc-pals "Delete pal: "))
338 ;;;###autoload
339 (defun erc-add-fool ()
340 "Add fool interactively to `erc-fools'."
341 (interactive)
342 (erc-add-entry-to-list 'erc-fools "Add fool: "
343 (erc-get-server-nickname-alist)))
345 ;;;###autoload
346 (defun erc-delete-fool ()
347 "Delete fool interactively to `erc-fools'."
348 (interactive)
349 (erc-remove-entry-from-list 'erc-fools "Delete fool: "))
351 ;;;###autoload
352 (defun erc-add-keyword ()
353 "Add keyword interactively to `erc-keywords'."
354 (interactive)
355 (erc-add-entry-to-list 'erc-keywords "Add keyword: "))
357 ;;;###autoload
358 (defun erc-delete-keyword ()
359 "Delete keyword interactively to `erc-keywords'."
360 (interactive)
361 (erc-remove-entry-from-list 'erc-keywords "Delete keyword: "))
363 ;;;###autoload
364 (defun erc-add-dangerous-host ()
365 "Add dangerous-host interactively to `erc-dangerous-hosts'."
366 (interactive)
367 (erc-add-entry-to-list 'erc-dangerous-hosts "Add dangerous-host: "))
369 ;;;###autoload
370 (defun erc-delete-dangerous-host ()
371 "Delete dangerous-host interactively to `erc-dangerous-hosts'."
372 (interactive)
373 (erc-remove-entry-from-list 'erc-dangerous-hosts "Delete dangerous-host: "))
375 (defun erc-match-current-nick-p (nickuserhost msg)
376 "Check whether the current nickname is in MSG.
377 NICKUSERHOST will be ignored."
378 (with-syntax-table erc-match-syntax-table
379 (and msg
380 (string-match (concat "\\b"
381 (regexp-quote (erc-current-nick))
382 "\\b")
383 msg))))
385 (defun erc-match-pal-p (nickuserhost msg)
386 "Check whether NICKUSERHOST is in `erc-pals'.
387 MSG will be ignored."
388 (and nickuserhost
389 (erc-list-match erc-pals nickuserhost)))
391 (defun erc-match-fool-p (nickuserhost msg)
392 "Check whether NICKUSERHOST is in `erc-fools' or MSG is directed at a fool."
393 (and msg nickuserhost
394 (or (erc-list-match erc-fools nickuserhost)
395 (erc-match-directed-at-fool-p msg))))
397 (defun erc-match-keyword-p (nickuserhost msg)
398 "Check whether any keyword of `erc-keywords' matches for MSG.
399 NICKUSERHOST will be ignored."
400 (and msg
401 (erc-list-match
402 (mapcar (lambda (x)
403 (if (listp x)
404 (car x)
406 erc-keywords)
407 msg)))
409 (defun erc-match-dangerous-host-p (nickuserhost msg)
410 "Check whether NICKUSERHOST is in `erc-dangerous-hosts'.
411 MSG will be ignored."
412 (and nickuserhost
413 (erc-list-match erc-dangerous-hosts nickuserhost)))
415 (defun erc-match-directed-at-fool-p (msg)
416 "Check whether MSG is directed at a fool.
417 In order to do this, every entry in `erc-fools' will be used.
418 In any of the following situations, MSG is directed at an entry FOOL:
420 - MSG starts with \"FOOL: \" or \"FOO, \"
421 - MSG contains \", FOOL.\" (actually, \"\\s. FOOL\\s.\")"
422 (let ((fools-beg (mapcar (lambda (entry)
423 (concat "^" entry "[:,] "))
424 erc-fools))
425 (fools-end (mapcar (lambda (entry)
426 (concat "\\s. " entry "\\s."))
427 erc-fools)))
428 (or (erc-list-match fools-beg msg)
429 (erc-list-match fools-end msg))))
431 (defun erc-match-message ()
432 "Mark certain keywords in a region.
433 Use this defun with `erc-insert-modify-hook'."
434 ;; This needs some refactoring.
435 (goto-char (point-min))
436 (let* ((to-match-nick-dep '("pal" "fool" "dangerous-host"))
437 (to-match-nick-indep '("keyword" "current-nick"))
438 (vector (erc-get-parsed-vector (point-min)))
439 (nickuserhost (erc-get-parsed-vector-nick vector))
440 (nickname (and nickuserhost
441 (nth 0 (erc-parse-user nickuserhost))))
442 (old-pt (point))
443 (nick-beg (and nickname
444 (re-search-forward (regexp-quote nickname)
445 (point-max) t)
446 (match-beginning 0)))
447 (nick-end (when nick-beg
448 (match-end 0)))
449 (message (buffer-substring (if (and nick-end
450 (<= (+ 2 nick-end) (point-max)))
451 (+ 2 nick-end)
452 (point-min))
453 (point-max))))
454 (when vector
455 (mapc
456 (lambda (match-type)
457 (goto-char (point-min))
458 (let* ((match-prefix (concat "erc-" match-type))
459 (match-pred (intern (concat "erc-match-" match-type "-p")))
460 (match-htype (eval (intern (concat match-prefix
461 "-highlight-type"))))
462 (match-regex (if (string= match-type "current-nick")
463 (regexp-quote (erc-current-nick))
464 (eval (intern (concat match-prefix "s")))))
465 (match-face (intern (concat match-prefix "-face"))))
466 (when (funcall match-pred nickuserhost message)
467 (cond
468 ;; Highlight the nick of the message
469 ((and (eq match-htype 'nick)
470 nick-end)
471 (erc-put-text-property
472 nick-beg nick-end
473 'face match-face (current-buffer)))
474 ;; Highlight the nick of the message, or the current
475 ;; nick if there's no nick in the message (e.g. /NAMES
476 ;; output)
477 ((and (string= match-type "current-nick")
478 (eq match-htype 'nick-or-keyword))
479 (if nick-end
480 (erc-put-text-property
481 nick-beg nick-end
482 'face match-face (current-buffer))
483 (goto-char (+ 2 (or nick-end
484 (point-min))))
485 (while (re-search-forward match-regex nil t)
486 (erc-put-text-property (match-beginning 0) (match-end 0)
487 'face match-face))))
488 ;; Highlight the whole message
489 ((eq match-htype 'all)
490 (erc-put-text-property
491 (point-min) (point-max)
492 'face match-face (current-buffer)))
493 ;; Highlight all occurrences of the word to be
494 ;; highlighted.
495 ((and (string= match-type "keyword")
496 (eq match-htype 'keyword))
497 (mapc (lambda (elt)
498 (let ((regex elt)
499 (face match-face))
500 (when (consp regex)
501 (setq regex (car elt)
502 face (cdr elt)))
503 (goto-char (+ 2 (or nick-end
504 (point-min))))
505 (while (re-search-forward regex nil t)
506 (erc-put-text-property
507 (match-beginning 0) (match-end 0)
508 'face face))))
509 match-regex))
510 ;; Highlight all occurrences of our nick.
511 ((and (string= match-type "current-nick")
512 (eq match-htype 'keyword))
513 (goto-char (+ 2 (or nick-end
514 (point-min))))
515 (while (re-search-forward match-regex nil t)
516 (erc-put-text-property (match-beginning 0) (match-end 0)
517 'face match-face)))
518 ;; Else twiddle your thumbs.
519 (t nil))
520 (run-hook-with-args
521 'erc-text-matched-hook
522 (intern match-type)
523 (or nickuserhost
524 (concat "Server:" (erc-get-parsed-vector-type vector)))
525 message))))
526 (if nickuserhost
527 (append to-match-nick-dep to-match-nick-indep)
528 to-match-nick-indep)))))
530 (defun erc-log-matches (match-type nickuserhost message)
531 "Log matches in a separate buffer, determined by MATCH-TYPE.
532 The behaviour of this function is controlled by the variables
533 `erc-log-matches-types-alist' and `erc-log-matches-flag'. Specify the
534 match types which should be logged in the former, and
535 deactivate/activate match logging in the latter. See
536 `erc-log-match-format'."
537 (let ((match-buffer-name (cdr (assq match-type
538 erc-log-matches-types-alist)))
539 (nick (nth 0 (erc-parse-user nickuserhost))))
540 (when (and
541 (or (eq erc-log-matches-flag t)
542 (and (eq erc-log-matches-flag 'away)
543 erc-away))
544 match-buffer-name)
545 (let ((line (format-spec erc-log-match-format
546 (format-spec-make
547 ?n nick
548 ?t (format-time-string
549 (or (and (boundp 'erc-timestamp-format)
550 erc-timestamp-format)
551 "[%Y-%m-%d %H:%M] "))
552 ?c (or (erc-default-target) "")
553 ?m message
554 ?u nickuserhost))))
555 (with-current-buffer (erc-log-matches-make-buffer match-buffer-name)
556 (let ((inhibit-read-only t))
557 (goto-char (point-max))
558 (insert line)))))))
560 (defun erc-log-matches-make-buffer (name)
561 "Create or get a log-matches buffer named NAME and return it."
562 (let* ((buffer-already (get-buffer name))
563 (buffer (or buffer-already
564 (get-buffer-create name))))
565 (with-current-buffer buffer
566 (unless buffer-already
567 (insert " == Type \"q\" to dismiss messages ==\n")
568 (erc-view-mode-enter nil (lambda (buffer)
569 (when (y-or-n-p "Discard messages? ")
570 (kill-buffer buffer)))))
571 buffer)))
573 (defun erc-log-matches-come-back (proc parsed)
574 "Display a notice that messages were logged while away."
575 (when (and erc-away
576 (eq erc-log-matches-flag 'away))
577 (mapc
578 (lambda (match-type)
579 (let ((buffer (get-buffer (cdr match-type)))
580 (buffer-name (cdr match-type)))
581 (when buffer
582 (let* ((last-msg-time (erc-emacs-time-to-erc-time
583 (with-current-buffer buffer
584 (get-text-property (1- (point-max))
585 'timestamp))))
586 (away-time (erc-emacs-time-to-erc-time erc-away)))
587 (when (and away-time last-msg-time
588 (erc-time-gt last-msg-time away-time))
589 (erc-display-message
590 nil 'notice 'active
591 (format "You have logged messages waiting in \"%s\"."
592 buffer-name))
593 (erc-display-message
594 nil 'notice 'active
595 (format "Type \"C-c C-k %s RET\" to view them."
596 buffer-name)))))))
597 erc-log-matches-types-alist))
598 nil)
600 ; This handler must be run _before_ erc-process-away is.
601 (add-hook 'erc-server-305-functions 'erc-log-matches-come-back nil)
603 (defun erc-go-to-log-matches-buffer ()
604 "Interactively open an erc-log-matches buffer."
605 (interactive)
606 (let ((buffer-name (completing-read "Switch to ERC Log buffer: "
607 (mapcar (lambda (x)
608 (cons (cdr x) t))
609 erc-log-matches-types-alist)
610 (lambda (buffer-cons)
611 (get-buffer (car buffer-cons))))))
612 (switch-to-buffer buffer-name)))
614 (define-key erc-mode-map "\C-c\C-k" 'erc-go-to-log-matches-buffer)
616 (defun erc-hide-fools (match-type nickuserhost message)
617 "Hide foolish comments.
618 This function should be called from `erc-text-matched-hook'."
619 (when (eq match-type 'fool)
620 (erc-put-text-properties (point-min) (point-max)
621 '(invisible intangible)
622 (current-buffer))))
624 (defun erc-beep-on-match (match-type nickuserhost message)
625 "Beep when text matches.
626 This function is meant to be called from `erc-text-matched-hook'."
627 (when (member match-type erc-beep-match-types)
628 (beep)))
630 (provide 'erc-match)
632 ;;; erc-match.el ends here
634 ;; Local Variables:
635 ;; indent-tabs-mode: t
636 ;; tab-width: 8
637 ;; End:
639 ;; arch-tag: 1f1f595e-abcc-4b0b-83db-598a1d3f0f82