diff options
Diffstat (limited to 'lisp/erc/erc-match.el')
| -rw-r--r-- | lisp/erc/erc-match.el | 658 |
1 files changed, 658 insertions, 0 deletions
diff --git a/lisp/erc/erc-match.el b/lisp/erc/erc-match.el new file mode 100644 index 00000000000..a5e3bf88ccf --- /dev/null +++ b/lisp/erc/erc-match.el @@ -0,0 +1,658 @@ +;;; erc-match.el --- Highlight messages matching certain regexps + +;; Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc. + +;; Author: Andreas Fuchs <asf@void.at> +;; Keywords: comm, faces +;; URL: http://www.emacswiki.org/cgi-bin/wiki.pl?ErcMatch + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; This file includes stuff to work with pattern matching in ERC. If +;; you were used to customizing erc-fools, erc-keywords, erc-pals, +;; erc-dangerous-hosts and the like, this file contains these +;; customizable variables. + +;; Usage: +;; Put (erc-match-mode 1) into your ~/.emacs file. + +;;; Code: + +(require 'erc) +(eval-when-compile (require 'cl)) + +;; Customisation: + +(defgroup erc-match nil + "Keyword and Friend/Foe/... recognition. +Group containing all things concerning pattern matching in ERC +messages." + :group 'erc) + +;;;###autoload (autoload 'erc-match-mode "erc-match") +(define-erc-module match nil + "This mode checks whether messages match certain patterns. If so, +they are hidden or highlighted. This is controlled via the variables +`erc-pals', `erc-fools', `erc-keywords', `erc-dangerous-hosts', and +`erc-current-nick-highlight-type'. For all these highlighting types, +you can decide whether the entire message or only the sending nick is +highlighted." + ((add-hook 'erc-insert-modify-hook 'erc-match-message 'append)) + ((remove-hook 'erc-insert-modify-hook 'erc-match-message))) + +;; Remaining customizations + +(defcustom erc-pals nil + "List of pals on IRC." + :group 'erc-match + :type '(repeat regexp)) + +(defcustom erc-fools nil + "List of fools on IRC." + :group 'erc-match + :type '(repeat regexp)) + +(defcustom erc-keywords nil + "List of keywords to highlight in all incoming messages. +Each entry in the list is either a regexp, or a cons cell with the +regexp in the car and the face to use in the cdr. If no face is +specified, `erc-keyword-face' is used." + :group 'erc-match + :type '(repeat (choice regexp + (list regexp face)))) + +(defcustom erc-dangerous-hosts nil + "List of regexps for hosts to highlight. +Useful to mark nicks from dangerous hosts." + :group 'erc-match + :type '(repeat regexp)) + +(defcustom erc-current-nick-highlight-type 'keyword + "*Determines how to highlight text in which your current nickname appears +\(does not apply to text sent by you\). + +The following values are allowed: + + nil - do not highlight the message at all + 'keyword - highlight all instances of current nickname in message + 'nick - highlight the nick of the user who typed your nickname + 'nick-or-keyword - highlight the nick of the user who typed your nickname, + or all instances of the current nickname if there was + no sending user + 'all - highlight the entire message where current nickname occurs + +Any other value disables highlighting of current nickname altogether." + :group 'erc-match + :type '(choice (const nil) + (const nick) + (const keyword) + (const nick-or-keyword) + (const all))) + +(defcustom erc-pal-highlight-type 'nick + "*Determines how to highlight messages by pals. +See `erc-pals'. + +The following values are allowed: + + nil - do not highlight the message at all + 'nick - highlight pal's nickname only + 'all - highlight the entire message from pal + +Any other value disables pal highlighting altogether." + :group 'erc-match + :type '(choice (const nil) + (const nick) + (const all))) + +(defcustom erc-fool-highlight-type 'nick + "*Determines how to highlight messages by fools. +See `erc-fools'. + +The following values are allowed: + + nil - do not highlight the message at all + 'nick - highlight fool's nickname only + 'all - highlight the entire message from fool + +Any other value disables fool highlighting altogether." + :group 'erc-match + :type '(choice (const nil) + (const nick) + (const all))) + +(defcustom erc-keyword-highlight-type 'keyword + "*Determines how to highlight messages containing keywords. +See variable `erc-keywords'. + +The following values are allowed: + + 'keyword - highlight keyword only + 'all - highlight the entire message containing keyword + +Any other value disables keyword highlighting altogether." + :group 'erc-match + :type '(choice (const nil) + (const keyword) + (const all))) + +(defcustom erc-dangerous-host-highlight-type 'nick + "*Determines how to highlight messages by nicks from dangerous-hosts. +See `erc-dangerous-hosts'. + +The following values are allowed: + + 'nick - highlight nick from dangerous-host only + 'all - highlight the entire message from dangerous-host + +Any other value disables dangerous-host highlighting altogether." + :group 'erc-match + :type '(choice (const nil) + (const nick) + (const all))) + + +(defcustom erc-log-matches-types-alist '((keyword . "ERC Keywords")) + "Alist telling ERC where to log which match types. +Valid match type keys are: +- keyword +- pal +- dangerous-host +- fool +- current-nick + +The other element of each cons pair in this list is the buffer name to +use for the logged message." + :group 'erc-match + :type '(repeat (cons (choice :tag "Key" + (const keyword) + (const pal) + (const dangerous-host) + (const fool) + (const current-nick)) + (string :tag "Buffer name")))) + +(defcustom erc-log-matches-flag 'away + "Flag specifying when matched message logging should happen. +When nil, don't log any matched messages. +When t, log messages. +When 'away, log messages only when away." + :group 'erc-match + :type '(choice (const nil) + (const away) + (const t))) + +(defcustom erc-log-match-format "%t<%n:%c> %m" + "Format for matched Messages. +This variable specifies how messages in the corresponding log buffers will +be formatted. The various format specs are: + +%t Timestamp (uses `erc-timestamp-format' if non-nil or \"[%Y-%m-%d %H:%M] \") +%n Nickname of sender +%u Nickname!user@host of sender +%c Channel in which this was received +%m Message" + :group 'erc-match + :type 'string) + +(defcustom erc-beep-match-types '(current-nick) + "Types of matches to beep for when a match occurs. +The function `erc-beep-on-match' needs to be added to `erc-text-matched-hook' +for beeping to work." + :group 'erc-match + :type '(choice (repeat :tag "Beep on match" (choice + (const current-nick) + (const keyword) + (const pal) + (const dangerous-host) + (const fool))) + (const :tag "Don't beep" nil))) + +(defcustom erc-text-matched-hook '(erc-log-matches) + "Hook run when text matches a given match-type. +Functions in this hook are passed as arguments: +\(match-type nick!user@host message) where MATCH-TYPE is a symbol of: +current-nick, keyword, pal, dangerous-host, fool" + :options '(erc-log-matches erc-hide-fools erc-beep-on-match) + :group 'erc-match + :type 'hook) + +;; Internal variables: + +;; This is exactly the same as erc-button-syntax-table. Should we +;; just put it in erc.el +(defvar erc-match-syntax-table + (let ((table (make-syntax-table))) + (modify-syntax-entry ?\( "w" table) + (modify-syntax-entry ?\) "w" table) + (modify-syntax-entry ?\[ "w" table) + (modify-syntax-entry ?\] "w" table) + (modify-syntax-entry ?\{ "w" table) + (modify-syntax-entry ?\} "w" table) + (modify-syntax-entry ?` "w" table) + (modify-syntax-entry ?' "w" table) + (modify-syntax-entry ?^ "w" table) + (modify-syntax-entry ?- "w" table) + (modify-syntax-entry ?_ "w" table) + (modify-syntax-entry ?| "w" table) + (modify-syntax-entry ?\\ "w" table) + table) + "Syntax table used when highlighting messages. +This syntax table should make all the legal nick characters word +constituents.") + +;; Faces: + +(defface erc-current-nick-face '((t (:bold t :foreground "DarkTurquoise"))) + "ERC face for occurrences of your current nickname." + :group 'erc-faces) + +(defface erc-dangerous-host-face '((t (:foreground "red"))) + "ERC face for people on dangerous hosts. +See `erc-dangerous-hosts'." + :group 'erc-faces) + +(defface erc-pal-face '((t (:bold t :foreground "Magenta"))) + "ERC face for your pals. +See `erc-pals'." + :group 'erc-faces) + +(defface erc-fool-face '((t (:foreground "dim gray"))) + "ERC face for fools on the channel. +See `erc-fools'." + :group 'erc-faces) + +(defface erc-keyword-face '((t (:bold t :foreground "pale green"))) + "ERC face for your keywords. +Note that this is the default face to use if +`erc-keywords' does not specify another." + :group 'erc-faces) + +;; Functions: + +(defun erc-add-entry-to-list (list prompt &optional completions) + "Add an entry interactively to a list. +LIST must be passed as a symbol +The query happens using PROMPT. +Completion is performed on the optional alist COMPLETIONS." + (let ((entry (completing-read + prompt + completions + (lambda (x) + (not (erc-member-ignore-case (car x) (symbol-value list))))))) + (if (erc-member-ignore-case entry (symbol-value list)) + (error (format "\"%s\" is already on the list" entry)) + (set list (cons entry (symbol-value list)))))) + +(defun erc-remove-entry-from-list (list prompt) + "Remove an entry interactively from a list. +LIST must be passed as a symbol. +The elements of LIST can be strings, or cons cells where the +car is the string." + (let* ((alist (mapcar (lambda (x) + (if (listp x) + x + (list x))) + (symbol-value list))) + (entry (completing-read + prompt + alist + nil + t))) + (if (erc-member-ignore-case entry (symbol-value list)) + ;; plain string + (set list (delete entry (symbol-value list))) + ;; cons cell + (set list (delete (assoc entry (symbol-value list)) + (symbol-value list)))))) + +;;;###autoload +(defun erc-add-pal () + "Add pal interactively to `erc-pals'." + (interactive) + (erc-add-entry-to-list 'erc-pals "Add pal: " (erc-get-server-nickname-alist))) + +;;;###autoload +(defun erc-delete-pal () + "Delete pal interactively to `erc-pals'." + (interactive) + (erc-remove-entry-from-list 'erc-pals "Delete pal: ")) + +;;;###autoload +(defun erc-add-fool () + "Add fool interactively to `erc-fools'." + (interactive) + (erc-add-entry-to-list 'erc-fools "Add fool: " + (erc-get-server-nickname-alist))) + +;;;###autoload +(defun erc-delete-fool () + "Delete fool interactively to `erc-fools'." + (interactive) + (erc-remove-entry-from-list 'erc-fools "Delete fool: ")) + +;;;###autoload +(defun erc-add-keyword () + "Add keyword interactively to `erc-keywords'." + (interactive) + (erc-add-entry-to-list 'erc-keywords "Add keyword: ")) + +;;;###autoload +(defun erc-delete-keyword () + "Delete keyword interactively to `erc-keywords'." + (interactive) + (erc-remove-entry-from-list 'erc-keywords "Delete keyword: ")) + +;;;###autoload +(defun erc-add-dangerous-host () + "Add dangerous-host interactively to `erc-dangerous-hosts'." + (interactive) + (erc-add-entry-to-list 'erc-dangerous-hosts "Add dangerous-host: ")) + +;;;###autoload +(defun erc-delete-dangerous-host () + "Delete dangerous-host interactively to `erc-dangerous-hosts'." + (interactive) + (erc-remove-entry-from-list 'erc-dangerous-hosts "Delete dangerous-host: ")) + +(defun erc-match-current-nick-p (nickuserhost msg) + "Check whether the current nickname is in MSG. +NICKUSERHOST will be ignored." + (with-syntax-table erc-match-syntax-table + (and msg + (string-match (concat "\\b" + (regexp-quote (erc-current-nick)) + "\\b") + msg)))) + +(defun erc-match-pal-p (nickuserhost msg) + "Check whether NICKUSERHOST is in `erc-pals'. +MSG will be ignored." + (and nickuserhost + (erc-list-match erc-pals nickuserhost))) + +(defun erc-match-fool-p (nickuserhost msg) + "Check whether NICKUSERHOST is in `erc-fools' or MSG is directed at a fool." + (and msg nickuserhost + (or (erc-list-match erc-fools nickuserhost) + (erc-match-directed-at-fool-p msg)))) + +(defun erc-match-keyword-p (nickuserhost msg) + "Check whether any keyword of `erc-keywords' matches for MSG. +NICKUSERHOST will be ignored." + (and msg + (erc-list-match + (mapcar (lambda (x) + (if (listp x) + (car x) + x)) + erc-keywords) + msg))) + +(defun erc-match-dangerous-host-p (nickuserhost msg) + "Check whether NICKUSERHOST is in `erc-dangerous-hosts'. +MSG will be ignored." + (and nickuserhost + (erc-list-match erc-dangerous-hosts nickuserhost))) + +(defun erc-match-directed-at-fool-p (msg) + "Check whether MSG is directed at a fool. +In order to do this, every entry in `erc-fools' will be used. +In any of the following situations, MSG is directed at an entry FOOL: + +- MSG starts with \"FOOL: \" or \"FOO, \" +- MSG contains \", FOOL.\" (actually, \"\\s. FOOL\\s.\")" + (let ((fools-beg (mapcar (lambda (entry) + (concat "^" entry "[:,] ")) + erc-fools)) + (fools-end (mapcar (lambda (entry) + (concat "\\s. " entry "\\s.")) + erc-fools))) + (or (erc-list-match fools-beg msg) + (erc-list-match fools-end msg)))) + +(defun erc-get-parsed-vector (point) + "Return the whole parsed vector on POINT." + (get-text-property point 'erc-parsed)) + +(defun erc-get-parsed-vector-nick (vect) + "Return nickname in the parsed vector VECT." + (let* ((untreated-nick (and vect (erc-response.sender vect))) + (maybe-nick (when untreated-nick + (car (split-string untreated-nick "!"))))) + (when (and (not (null maybe-nick)) + (erc-is-valid-nick-p maybe-nick)) + untreated-nick))) + +(defun erc-get-parsed-vector-type (vect) + "Return message type in the parsed vector VECT." + (and vect + (erc-response.command vect))) + +(defun erc-match-message () + "Mark certain keywords in a region. +Use this defun with `erc-insert-modify-hook'." + ;; This needs some refactoring. + (goto-char (point-min)) + (let* ((to-match-nick-dep '("pal" "fool" "dangerous-host")) + (to-match-nick-indep '("keyword" "current-nick")) + (vector (erc-get-parsed-vector (point-min))) + (nickuserhost (erc-get-parsed-vector-nick vector)) + (nickname (and nickuserhost + (nth 0 (erc-parse-user nickuserhost)))) + (old-pt (point)) + (nick-beg (and nickname + (re-search-forward (regexp-quote nickname) + (point-max) t) + (match-beginning 0))) + (nick-end (when nick-beg + (match-end 0))) + (message (buffer-substring (if (and nick-end + (<= (+ 2 nick-end) (point-max))) + (+ 2 nick-end) + (point-min)) + (point-max)))) + (when vector + (mapc + (lambda (match-type) + (goto-char (point-min)) + (let* ((match-prefix (concat "erc-" match-type)) + (match-pred (intern (concat "erc-match-" match-type "-p"))) + (match-htype (eval (intern (concat match-prefix + "-highlight-type")))) + (match-regex (if (string= match-type "current-nick") + (regexp-quote (erc-current-nick)) + (eval (intern (concat match-prefix "s"))))) + (match-face (intern (concat match-prefix "-face")))) + (when (funcall match-pred nickuserhost message) + (cond + ;; Highlight the nick of the message + ((and (eq match-htype 'nick) + nick-end) + (erc-put-text-property + nick-beg nick-end + 'face match-face (current-buffer))) + ;; Highlight the nick of the message, or the current + ;; nick if there's no nick in the message (e.g. /NAMES + ;; output) + ((and (string= match-type "current-nick") + (eq match-htype 'nick-or-keyword)) + (if nick-end + (erc-put-text-property + nick-beg nick-end + 'face match-face (current-buffer)) + (goto-char (+ 2 (or nick-end + (point-min)))) + (while (re-search-forward match-regex nil t) + (erc-put-text-property (match-beginning 0) (match-end 0) + 'face match-face)))) + ;; Highlight the whole message + ((eq match-htype 'all) + (erc-put-text-property + (point-min) (point-max) + 'face match-face (current-buffer))) + ;; Highlight all occurrences of the word to be + ;; highlighted. + ((and (string= match-type "keyword") + (eq match-htype 'keyword)) + (mapc (lambda (elt) + (let ((regex elt) + (face match-face)) + (when (consp regex) + (setq regex (car elt) + face (cdr elt))) + (goto-char (+ 2 (or nick-end + (point-min)))) + (while (re-search-forward regex nil t) + (erc-put-text-property + (match-beginning 0) (match-end 0) + 'face face)))) + match-regex)) + ;; Highlight all occurrences of our nick. + ((and (string= match-type "current-nick") + (eq match-htype 'keyword)) + (goto-char (+ 2 (or nick-end + (point-min)))) + (while (re-search-forward match-regex nil t) + (erc-put-text-property (match-beginning 0) (match-end 0) + 'face match-face))) + ;; Else twiddle your thumbs. + (t nil)) + (run-hook-with-args + 'erc-text-matched-hook + (intern match-type) + (or nickuserhost + (concat "Server:" (erc-get-parsed-vector-type vector))) + message)))) + (if nickuserhost + (append to-match-nick-dep to-match-nick-indep) + to-match-nick-indep))))) + +(defun erc-log-matches (match-type nickuserhost message) + "Log matches in a separate buffer, determined by MATCH-TYPE. +The behaviour of this function is controlled by the variables +`erc-log-matches-types-alist' and `erc-log-matches-flag'. Specify the +match types which should be logged in the former, and +deactivate/activate match logging in the latter. See +`erc-log-match-format'." + (let ((match-buffer-name (cdr (assq match-type + erc-log-matches-types-alist))) + (nick (nth 0 (erc-parse-user nickuserhost)))) + (when (and + (or (eq erc-log-matches-flag t) + (and (eq erc-log-matches-flag 'away) + erc-away)) + match-buffer-name) + (let ((line (format-spec erc-log-match-format + (format-spec-make + ?n nick + ?t (format-time-string + (or (and (boundp 'erc-timestamp-format) + erc-timestamp-format) + "[%Y-%m-%d %H:%M] ")) + ?c (or (erc-default-target) "") + ?m message + ?u nickuserhost)))) + (with-current-buffer (erc-log-matches-make-buffer match-buffer-name) + (toggle-read-only -1) + (point-max) + (insert line) + (toggle-read-only 1)))))) + +(defun erc-log-matches-make-buffer (name) + "Create or get a log-matches buffer named NAME and return it." + (let* ((buffer-already (get-buffer name)) + (buffer (or buffer-already + (get-buffer-create name)))) + (with-current-buffer buffer + (unless buffer-already + (insert " == Type \"q\" to dismiss messages ==\n") + (erc-view-mode-enter nil (lambda (buffer) + (when (y-or-n-p "Discard messages?") + (kill-buffer buffer))))) + buffer))) + +(defun erc-log-matches-come-back (proc parsed) + "Display a notice that messages were logged while away." + (when (and erc-away + (eq erc-log-matches-flag 'away)) + (mapc + (lambda (match-type) + (let ((buffer (get-buffer (cdr match-type))) + (buffer-name (cdr match-type))) + (when buffer + (let* ((last-msg-time (erc-emacs-time-to-erc-time + (with-current-buffer buffer + (get-text-property (1- (point-max)) + 'timestamp)))) + (away-time (erc-emacs-time-to-erc-time erc-away))) + (when (and away-time last-msg-time + (erc-time-gt last-msg-time away-time)) + (erc-display-message + nil 'notice 'active + (format "You have logged messages waiting in \"%s\"." + buffer-name)) + (erc-display-message + nil 'notice 'active + (format "Type \"C-c C-k %s RET\" to view them." + buffer-name))))))) + erc-log-matches-types-alist)) + nil) + +; This handler must be run _before_ erc-process-away is. +(add-hook 'erc-server-305-functions 'erc-log-matches-come-back nil) + +(defun erc-go-to-log-matches-buffer () + "Interactively open an erc-log-matches buffer." + (interactive) + (let ((buffer-name (completing-read "Switch to ERC Log buffer: " + (mapcar (lambda (x) + (cons (cdr x) t)) + erc-log-matches-types-alist) + (lambda (buffer-cons) + (get-buffer (car buffer-cons)))))) + (switch-to-buffer buffer-name))) + +(define-key erc-mode-map "\C-c\C-k" 'erc-go-to-log-matches-buffer) + +(defun erc-hide-fools (match-type nickuserhost message) + "Hide foolish comments. +This function should be called from `erc-text-matched-hook'." + (when (eq match-type 'fool) + (erc-put-text-properties (point-min) (point-max) + '(invisible intangible) + (current-buffer)))) + +(defun erc-beep-on-match (match-type nickuserhost message) + "Beep when text matches. +This function is meant to be called from `erc-text-matched-hook'." + (when (member match-type erc-beep-match-types) + (beep))) + +(provide 'erc-match) + +;;; erc-match.el ends here +;; +;; Local Variables: +;; indent-tabs-mode: t +;; tab-width: 8 +;; End: + +;; arch-tag: 1f1f595e-abcc-4b0b-83db-598a1d3f0f82 |