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