diff lisp/erc/erc-match.el @ 68451:fc745b05e928

Revision: [e-mail]/emacs--devo--0--patch-22 Creator: Michael Olson <[e-mail]> Install ERC.

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/erc/erc-match.el	Sun Jan 29 13:08:58 2006 +0000
@@ -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 <[e-mail]>
+;; 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