1 ;;; erc-match.el --- Highlight messages matching certain regexps
3 ;; Copyright (C) 2002-2017 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 'font-lock-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 'font-lock-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)
503 'font-lock-face match-face
))))
504 ;; Highlight the whole message
505 ((eq match-htype
'all
)
506 (erc-put-text-property
507 (point-min) (point-max)
508 'font-lock-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)
524 'font-lock-face face
))))
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)
533 'font-lock-face match-face
)))
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