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