[beirc-cvs] CVS beirc

[rgoldman]

Update of /project/beirc/cvsroot/beirc
In directory clnet:/tmp/cvs-serv15877

Modified Files:
	application.lisp beirc.asd variables.lisp 
Added Files:
	post-message-hooks.lisp 
Log Message:
Added support for making noise on certain messages.

--- /project/beirc/cvsroot/beirc/application.lisp	2006/03/21 22:50:21	1.68
+++ /project/beirc/cvsroot/beirc/application.lisp	2006/03/24 21:19:43	1.69
@@ -309,25 +309,29 @@
   (typep message '(or irc:irc-privmsg-message irc:irc-notice-message irc:irc-topic-message irc:irc-kick-message irc:ctcp-action-message)))
 
 (defun post-message-to-receiver (frame message receiver)
-  (setf (messages receiver)
-        (append (messages receiver) (list message)))
-  (unless (eql receiver (current-receiver frame))
-    (when (interesting-message-p message)
-      (incf (unseen-messages receiver)))
-    (when (message-directed-to-me-p message)
-      (incf (messages-directed-to-me receiver)))
-    (incf (all-unseen-messages receiver)))
-  (when (and (slot-boundp receiver 'pane) (pane receiver))
-    (let* ((pane (actual-application-pane (pane receiver)))
-           (current-insert-position (bounding-rectangle-height pane)))
-      (when (and (not (eql current-insert-position
-                           (first (positions-mentioning-user receiver))))
-                 (message-directed-to-me-p message))
-        (push current-insert-position
-              (positions-mentioning-user receiver)))))
-  (queue-event (frame-top-level-sheet frame)
-               (make-instance 'foo-event :sheet frame :receiver receiver))
-  nil)
+  (let ((message-to-me-p (message-directed-to-me-p message))
+	(interesting-message-p (interesting-message-p message)))
+    (setf (messages receiver)
+      (append (messages receiver) (list message)))
+    (unless (eql receiver (current-receiver frame))
+      (when interesting-message-p
+	(incf (unseen-messages receiver)))
+      (when message-to-me-p
+	(incf (messages-directed-to-me receiver)))
+      (incf (all-unseen-messages receiver)))
+    (when (and (slot-boundp receiver 'pane) (pane receiver))
+      (let* ((pane (actual-application-pane (pane receiver)))
+	     (current-insert-position (bounding-rectangle-height pane)))
+	(when (and (not (eql current-insert-position
+			     (first (positions-mentioning-user receiver))))
+		   message-to-me-p)
+	  (push current-insert-position
+		(positions-mentioning-user receiver)))))
+    (run-post-message-hooks message frame receiver :message-directed-to-me message-to-me-p
+			    :message-interesting-p interesting-message-p)
+    (queue-event (frame-top-level-sheet frame)
+		 (make-instance 'foo-event :sheet frame :receiver receiver))
+    nil))
 
 (defun post-message (frame message)
   (let ((receiver (receiver-for-message message frame)))
--- /project/beirc/cvsroot/beirc/beirc.asd	2006/03/12 09:48:57	1.7
+++ /project/beirc/cvsroot/beirc/beirc.asd	2006/03/24 21:19:43	1.8
@@ -14,4 +14,6 @@
                (:file "presentations" :depends-on ("package" "variables" "receivers"))
                (:file "message-display" :depends-on ("package" "variables" "presentations"))
                (:file "application" :depends-on ("package" "variables" "presentations" "events" "receivers"))
-               (:file "message-processing" :depends-on ("package" "variables" "receivers" "application"))))
\ No newline at end of file
+               (:file "message-processing" :depends-on ("package" "variables" "receivers" "application"))
+	       (:file "post-message-hooks" :depends-on ("package"))
+	       ))
\ No newline at end of file
--- /project/beirc/cvsroot/beirc/variables.lisp	2006/03/21 15:22:03	1.11
+++ /project/beirc/cvsroot/beirc/variables.lisp	2006/03/24 21:19:44	1.12
@@ -6,7 +6,15 @@
 (defvar *default-nick* (format nil "Brucio-~d" (random 100)))
 (defvar *default-web-browser* #+darwin "/usr/bin/open"
                               ;; assuming a debian system running X:
-                              #+linux  "/usr/bin/x-www-browser")
+	#+linux  "/usr/bin/x-www-browser")
+(defvar *default-sound-player* 
+    (or nil
+	#+linux "/usr/bin/ogg123")
+  "An external program that can be used to produce sounds.")
+(defvar *sound-for-my-nick* nil
+  "If the NOISEMAKER post-message-hook is enabled, and there
+is a *default-sound-player* defined, this noise will be 
+played when your nick is mentioned.")
 
 (defvar *auto-join-alist* '(("irc.freenode.net" . ("#beirc")))
   "An alist mapping irc server name to a list of channels to

--- /project/beirc/cvsroot/beirc/post-message-hooks.lisp	2006/03/24 21:19:44	NONE
+++ /project/beirc/cvsroot/beirc/post-message-hooks.lisp	2006/03/24 21:19:44	1.1
(in-package :beirc)

(defvar *post-message-hooks* (make-hash-table)
  "Table of hooks to be run when a message is posted to a receiver.")

(defun run-post-message-hooks (message frame receiver &rest args)
  (maphash #'(lambda (k v)
	       (declare (ignore k))
	       (apply v message frame receiver args))
	   *post-message-hooks*)
  (values))

(defmacro define-post-message-hook (hook-name (message-var frame-var receiver-var &rest other-args) &body body)
  "Convenience macro for defining hooks that are run when a message is posted to a receiver."
  `(progn (defun ,hook-name (,message-var ,frame-var ,receiver-var , at other-args &allow-other-keys) , at body)
	  (setf (gethash ',hook-name *post-message-hooks*) ',hook-name)))

;;;---------------------------------------------------------------------------
;;; If you set *default-sound-player* and *sound-for-my-nick* this
;;; should work...  It leaves a lot to be desired.  This should
;;; probably turn into some kind of general noisemaking interface...
;;; But this should get us thinking. [2006/03/24:rpg]
;;;---------------------------------------------------------------------------
(define-post-message-hook noisemaker (msg frame receiver &key message-directed-to-me)
  (declare (ignore msg frame receiver))
  (when (and message-directed-to-me
	     *default-sound-player* 
	     *sound-for-my-nick*)
    #+allegro
    (excl:run-shell-command (format nil "~A ~A" *default-sound-player* *sound-for-my-nick*)
			    :error-output "/dev/null" :if-error-output-exists :append :wait t)))