1 ;;; erc-match.el --- Highlight messages matching certain regexps
3 ;; Copyright (C) 2002-2015 Free Software Foundation, Inc.
5 ;; Author: Andreas Fuchs <asf@void.at>
6 ;; Maintainer: emacs-devel@gnu.org
7 ;; Keywords: comm, faces
8 ;; URL: http://www.emacswiki.org/cgi-bin/wiki.pl?ErcMatch
10 ;; This file is part of GNU Emacs.
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.
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.
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/>.
27 ;; This file includes stuff to work with pattern matching in ERC. If
28 ;; you were used to customizing erc-fools, erc-keywords, erc-pals,
29 ;; erc-dangerous-hosts and the like, this file contains these
30 ;; customizable variables.
33 ;; Put (erc-match-mode 1) into your init file.
41 (defgroup erc-match nil
42 "Keyword and Friend/Foe/... recognition.
43 Group containing all things concerning pattern matching in ERC
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
55 ((add-hook 'erc-insert-modify-hook
'erc-match-message
'append
))
56 ((remove-hook 'erc-insert-modify-hook
'erc-match-message
)))
58 ;; Remaining customizations
60 (defcustom erc-pals nil
61 "List of pals on IRC."
63 :type
'(repeat regexp
))
65 (defcustom erc-fools nil
66 "List of fools on IRC."
68 :type
'(repeat regexp
))
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."
76 :type
'(repeat (choice regexp
79 (defcustom erc-dangerous-hosts nil
80 "List of regexps for hosts to highlight.
81 Useful to mark nicks from dangerous hosts."
83 :type
'(repeat regexp
))
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\).
89 The following values are allowed:
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
97 'all - highlight the entire message where current nickname occurs
99 Any other value disables highlighting of current nickname altogether."
101 :type
'(choice (const nil
)
104 (const nick-or-keyword
)
107 (defcustom erc-pal-highlight-type
'nick
108 "Determines how to highlight messages by pals.
111 The following values are allowed:
113 nil - do not highlight the message at all
114 'nick - highlight pal's nickname only
115 'all - highlight the entire message from pal
117 Any other value disables pal highlighting altogether."
119 :type
'(choice (const nil
)
123 (defcustom erc-fool-highlight-type
'nick
124 "Determines how to highlight messages by fools.
127 The following values are allowed:
129 nil - do not highlight the message at all
130 'nick - highlight fool's nickname only
131 'all - highlight the entire message from fool
133 Any other value disables fool highlighting altogether."
135 :type
'(choice (const nil
)
139 (defcustom erc-keyword-highlight-type
'keyword
140 "Determines how to highlight messages containing keywords.
141 See variable `erc-keywords'.
143 The following values are allowed:
145 'keyword - highlight keyword only
146 'all - highlight the entire message containing keyword
148 Any other value disables keyword highlighting altogether."
150 :type
'(choice (const nil
)
154 (defcustom erc-dangerous-host-highlight-type
'nick
155 "Determines how to highlight messages by nicks from dangerous-hosts.
156 See `erc-dangerous-hosts'.
158 The following values are allowed:
160 'nick - highlight nick from dangerous-host only
161 'all - highlight the entire message from dangerous-host
163 Any other value disables dangerous-host highlighting altogether."
165 :type
'(choice (const nil
)
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:
179 The other element of each cons pair in this list is the buffer name to
180 use for the logged message."
182 :type
'(repeat (cons (choice :tag
"Key"
185 (const dangerous-host
)
187 (const current-nick
))
188 (string :tag
"Buffer name"))))
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."
196 :type
'(choice (const nil
)
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:
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
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."
218 :type
'(choice (repeat :tag
"Beep on match" (choice
222 (const dangerous-host
)
224 (const :tag
"Don't beep" nil
)))
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
)
235 (defcustom erc-match-exclude-server-buffer nil
236 "If true, don't perform match on the server buffer; this is
237 useful for excluding all the things like MOTDs from the server
238 and other miscellaneous functions."
243 ;; Internal variables:
245 ;; This is exactly the same as erc-button-syntax-table. Should we
246 ;; just put it in erc.el
247 (defvar erc-match-syntax-table
248 (let ((table (make-syntax-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 (modify-syntax-entry ?
' "w" table
)
257 (modify-syntax-entry ?^
"w" table
)
258 (modify-syntax-entry ?-
"w" table
)
259 (modify-syntax-entry ?_
"w" table
)
260 (modify-syntax-entry ?|
"w" table
)
261 (modify-syntax-entry ?
\\ "w" table
)
263 "Syntax table used when highlighting messages.
264 This syntax table should make all the valid nick characters word
269 (defface erc-current-nick-face
'((t :weight bold
:foreground
"DarkTurquoise"))
270 "ERC face for occurrences of your current nickname."
273 (defface erc-dangerous-host-face
'((t :foreground
"red"))
274 "ERC face for people on dangerous hosts.
275 See `erc-dangerous-hosts'."
278 (defface erc-pal-face
'((t :weight bold
:foreground
"Magenta"))
279 "ERC face for your pals.
283 (defface erc-fool-face
'((t :foreground
"dim gray"))
284 "ERC face for fools on the channel.
288 (defface erc-keyword-face
'((t :weight bold
:foreground
"pale green"))
289 "ERC face for your keywords.
290 Note that this is the default face to use if
291 `erc-keywords' does not specify another."
296 (defun erc-add-entry-to-list (list prompt
&optional completions
)
297 "Add an entry interactively to a list.
298 LIST must be passed as a symbol
299 The query happens using PROMPT.
300 Completion is performed on the optional alist COMPLETIONS."
301 (let ((entry (completing-read
305 (not (erc-member-ignore-case (car x
) (symbol-value list
)))))))
306 (if (erc-member-ignore-case entry
(symbol-value list
))
307 (error "\"%s\" is already on the list" entry
)
308 (set list
(cons entry
(symbol-value list
))))))
310 (defun erc-remove-entry-from-list (list prompt
)
311 "Remove an entry interactively from a list.
312 LIST must be passed as a symbol.
313 The elements of LIST can be strings, or cons cells where the
315 (let* ((alist (mapcar (lambda (x)
319 (symbol-value list
)))
320 (entry (completing-read
325 (if (erc-member-ignore-case entry
(symbol-value list
))
327 (set list
(delete entry
(symbol-value list
)))
329 (set list
(delete (assoc entry
(symbol-value list
))
330 (symbol-value list
))))))
333 (defun erc-add-pal ()
334 "Add pal interactively to `erc-pals'."
336 (erc-add-entry-to-list 'erc-pals
"Add pal: " (erc-get-server-nickname-alist)))
339 (defun erc-delete-pal ()
340 "Delete pal interactively to `erc-pals'."
342 (erc-remove-entry-from-list 'erc-pals
"Delete pal: "))
345 (defun erc-add-fool ()
346 "Add fool interactively to `erc-fools'."
348 (erc-add-entry-to-list 'erc-fools
"Add fool: "
349 (erc-get-server-nickname-alist)))
352 (defun erc-delete-fool ()
353 "Delete fool interactively to `erc-fools'."
355 (erc-remove-entry-from-list 'erc-fools
"Delete fool: "))
358 (defun erc-add-keyword ()
359 "Add keyword interactively to `erc-keywords'."
361 (erc-add-entry-to-list 'erc-keywords
"Add keyword: "))
364 (defun erc-delete-keyword ()
365 "Delete keyword interactively to `erc-keywords'."
367 (erc-remove-entry-from-list 'erc-keywords
"Delete keyword: "))
370 (defun erc-add-dangerous-host ()
371 "Add dangerous-host interactively to `erc-dangerous-hosts'."
373 (erc-add-entry-to-list 'erc-dangerous-hosts
"Add dangerous-host: "))
376 (defun erc-delete-dangerous-host ()
377 "Delete dangerous-host interactively to `erc-dangerous-hosts'."
379 (erc-remove-entry-from-list 'erc-dangerous-hosts
"Delete dangerous-host: "))
381 (defun erc-match-current-nick-p (nickuserhost msg
)
382 "Check whether the current nickname is in MSG.
383 NICKUSERHOST will be ignored."
384 (with-syntax-table erc-match-syntax-table
386 (string-match (concat "\\b"
387 (regexp-quote (erc-current-nick))
391 (defun erc-match-pal-p (nickuserhost msg
)
392 "Check whether NICKUSERHOST is in `erc-pals'.
393 MSG will be ignored."
395 (erc-list-match erc-pals nickuserhost
)))
397 (defun erc-match-fool-p (nickuserhost msg
)
398 "Check whether NICKUSERHOST is in `erc-fools' or MSG is directed at a fool."
399 (and msg nickuserhost
400 (or (erc-list-match erc-fools nickuserhost
)
401 (erc-match-directed-at-fool-p msg
))))
403 (defun erc-match-keyword-p (nickuserhost msg
)
404 "Check whether any keyword of `erc-keywords' matches for MSG.
405 NICKUSERHOST will be ignored."
415 (defun erc-match-dangerous-host-p (nickuserhost msg
)
416 "Check whether NICKUSERHOST is in `erc-dangerous-hosts'.
417 MSG will be ignored."
419 (erc-list-match erc-dangerous-hosts nickuserhost
)))
421 (defun erc-match-directed-at-fool-p (msg)
422 "Check whether MSG is directed at a fool.
423 In order to do this, every entry in `erc-fools' will be used.
424 In any of the following situations, MSG is directed at an entry FOOL:
426 - MSG starts with \"FOOL: \" or \"FOO, \"
427 - MSG contains \", FOOL.\" (actually, \"\\s. FOOL\\s.\")"
428 (let ((fools-beg (mapcar (lambda (entry)
429 (concat "^" entry
"[:,] "))
431 (fools-end (mapcar (lambda (entry)
432 (concat "\\s. " entry
"\\s."))
434 (or (erc-list-match fools-beg msg
)
435 (erc-list-match fools-end msg
))))
437 (defun erc-match-message ()
438 "Mark certain keywords in a region.
439 Use this defun with `erc-insert-modify-hook'."
440 ;; This needs some refactoring.
441 (goto-char (point-min))
442 (let* ((to-match-nick-dep '("pal" "fool" "dangerous-host"))
443 (to-match-nick-indep '("keyword" "current-nick"))
444 (vector (erc-get-parsed-vector (point-min)))
445 (nickuserhost (erc-get-parsed-vector-nick vector
))
446 (nickname (and nickuserhost
447 (nth 0 (erc-parse-user nickuserhost
))))
449 (nick-beg (and nickname
450 (re-search-forward (regexp-quote nickname
)
452 (match-beginning 0)))
453 (nick-end (when nick-beg
455 (message (buffer-substring
457 (<= (+ 2 nick-end
) (point-max)))
458 ;; Message starts 2 characters after the nick
459 ;; except for CTCP ACTION messages. Nick
460 ;; surrounded by angle brackets only in normal
463 (if (eq ?
> (char-after nick-end
))
469 (not (and erc-match-exclude-server-buffer
470 (erc-server-buffer-p))))
473 (goto-char (point-min))
474 (let* ((match-prefix (concat "erc-" match-type
))
475 (match-pred (intern (concat "erc-match-" match-type
"-p")))
476 (match-htype (eval (intern (concat match-prefix
477 "-highlight-type"))))
478 (match-regex (if (string= match-type
"current-nick")
479 (regexp-quote (erc-current-nick))
480 (eval (intern (concat match-prefix
"s")))))
481 (match-face (intern (concat match-prefix
"-face"))))
482 (when (funcall match-pred nickuserhost message
)
484 ;; Highlight the nick of the message
485 ((and (eq match-htype
'nick
)
487 (erc-put-text-property
489 'face match-face
(current-buffer)))
490 ;; Highlight the nick of the message, or the current
491 ;; nick if there's no nick in the message (e.g. /NAMES
493 ((and (string= match-type
"current-nick")
494 (eq match-htype
'nick-or-keyword
))
496 (erc-put-text-property
498 'face match-face
(current-buffer))
499 (goto-char (+ 2 (or nick-end
501 (while (re-search-forward match-regex nil t
)
502 (erc-put-text-property (match-beginning 0) (match-end 0)
504 ;; Highlight the whole message
505 ((eq match-htype
'all
)
506 (erc-put-text-property
507 (point-min) (point-max)
508 'face match-face
(current-buffer)))
509 ;; Highlight all occurrences of the word to be
511 ((and (string= match-type
"keyword")
512 (eq match-htype
'keyword
))
517 (setq regex
(car elt
)
519 (goto-char (+ 2 (or nick-end
521 (while (re-search-forward regex nil t
)
522 (erc-put-text-property
523 (match-beginning 0) (match-end 0)
526 ;; Highlight all occurrences of our nick.
527 ((and (string= match-type
"current-nick")
528 (eq match-htype
'keyword
))
529 (goto-char (+ 2 (or nick-end
531 (while (re-search-forward match-regex nil t
)
532 (erc-put-text-property (match-beginning 0) (match-end 0)
534 ;; Else twiddle your thumbs.
537 'erc-text-matched-hook
540 (concat "Server:" (erc-get-parsed-vector-type vector
)))
543 (append to-match-nick-dep to-match-nick-indep
)
544 to-match-nick-indep
)))))
546 (defun erc-log-matches (match-type nickuserhost message
)
547 "Log matches in a separate buffer, determined by MATCH-TYPE.
548 The behavior of this function is controlled by the variables
549 `erc-log-matches-types-alist' and `erc-log-matches-flag'.
550 Specify the match types which should be logged in the former,
551 and deactivate/activate match logging in the latter.
552 See `erc-log-match-format'."
553 (let ((match-buffer-name (cdr (assq match-type
554 erc-log-matches-types-alist
)))
555 (nick (nth 0 (erc-parse-user nickuserhost
))))
557 (or (eq erc-log-matches-flag t
)
558 (and (eq erc-log-matches-flag
'away
)
561 (let ((line (format-spec erc-log-match-format
564 ?t
(format-time-string
565 (or (and (boundp 'erc-timestamp-format
)
566 erc-timestamp-format
)
567 "[%Y-%m-%d %H:%M] "))
568 ?c
(or (erc-default-target) "")
571 (with-current-buffer (erc-log-matches-make-buffer match-buffer-name
)
572 (let ((inhibit-read-only t
))
573 (goto-char (point-max))
576 (defun erc-log-matches-make-buffer (name)
577 "Create or get a log-matches buffer named NAME and return it."
578 (let* ((buffer-already (get-buffer name
))
579 (buffer (or buffer-already
580 (get-buffer-create name
))))
581 (with-current-buffer buffer
582 (unless buffer-already
583 (insert " == Type \"q\" to dismiss messages ==\n")
584 (erc-view-mode-enter nil
(lambda (buffer)
585 (when (y-or-n-p "Discard messages? ")
586 (kill-buffer buffer
)))))
589 (defun erc-log-matches-come-back (proc parsed
)
590 "Display a notice that messages were logged while away."
591 (when (and (erc-away-time)
592 (eq erc-log-matches-flag
'away
))
595 (let ((buffer (get-buffer (cdr match-type
)))
596 (buffer-name (cdr match-type
)))
598 (let* ((last-msg-time (erc-emacs-time-to-erc-time
599 (with-current-buffer buffer
600 (get-text-property (1- (point-max))
602 (away-time (erc-emacs-time-to-erc-time (erc-away-time))))
603 (when (and away-time last-msg-time
604 (erc-time-gt last-msg-time away-time
))
607 (format "You have logged messages waiting in \"%s\"."
611 (format "Type \"C-c C-k %s RET\" to view them."
613 erc-log-matches-types-alist
))
616 ; This handler must be run _before_ erc-process-away is.
617 (add-hook 'erc-server-305-functions
'erc-log-matches-come-back nil
)
619 (defun erc-go-to-log-matches-buffer ()
620 "Interactively open an erc-log-matches buffer."
622 (let ((buffer-name (completing-read "Switch to ERC Log buffer: "
625 erc-log-matches-types-alist
)
626 (lambda (buffer-cons)
627 (get-buffer (car buffer-cons
))))))
628 (switch-to-buffer buffer-name
)))
630 (define-key erc-mode-map
"\C-c\C-k" 'erc-go-to-log-matches-buffer
)
632 (defun erc-hide-fools (match-type nickuserhost message
)
633 "Hide foolish comments.
634 This function should be called from `erc-text-matched-hook'."
635 (when (eq match-type
'fool
)
636 (erc-put-text-properties (point-min) (point-max)
637 '(invisible intangible
)
640 (defun erc-beep-on-match (match-type nickuserhost message
)
641 "Beep when text matches.
642 This function is meant to be called from `erc-text-matched-hook'."
643 (when (member match-type erc-beep-match-types
)
648 ;;; erc-match.el ends here
651 ;; indent-tabs-mode: t