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