1;;; earcon.el --- Sound effects for messages 2 3;; Copyright (C) 1996, 2000, 2001, 2002, 2003, 2004, 4;; 2005, 2006, 2007 Free Software Foundation, Inc. 5 6;; Author: Steven L. Baur <steve@miranova.com> 7 8;; This file is part of GNU Emacs. 9 10;; GNU Emacs is free software; you can redistribute it and/or modify 11;; it under the terms of the GNU General Public License as published by 12;; the Free Software Foundation; either version 2, or (at your option) 13;; any later version. 14 15;; GNU Emacs is distributed in the hope that it will be useful, 16;; but WITHOUT ANY WARRANTY; without even the implied warranty of 17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18;; GNU General Public License for more details. 19 20;; You should have received a copy of the GNU General Public License 21;; along with GNU Emacs; see the file COPYING. If not, write to the 22;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 23;; Boston, MA 02110-1301, USA. 24 25;;; Commentary: 26;; This file provides access to sound effects in Gnus. 27 28;;; Code: 29 30(eval-when-compile (require 'cl)) 31(require 'gnus) 32(require 'gnus-audio) 33(require 'gnus-art) 34 35(defgroup earcon nil 36 "Turn ** sounds ** into noise." 37 :group 'gnus-visual) 38 39(defcustom earcon-prefix "**" 40 "*String denoting the start of an earcon." 41 :type 'string 42 :group 'earcon) 43 44(defcustom earcon-suffix "**" 45 "String denoting the end of an earcon." 46 :type 'string 47 :group 'earcon) 48 49(defcustom earcon-regexp-alist 50 '(("boring" 1 "Boring.au") 51 ("evil[ \t]+laugh" 1 "Evil_Laugh.au") 52 ("gag\\|puke" 1 "Puke.au") 53 ("snicker" 1 "Snicker.au") 54 ("meow" 1 "catmeow.wav") 55 ("sob\\|boohoo" 1 "cry.wav") 56 ("drum[ \t]*roll" 1 "drumroll.au") 57 ("blast" 1 "explosion.au") 58 ("flush\\|plonk!*" 1 "flush.au") 59 ("kiss" 1 "kiss.wav") 60 ("tee[ \t]*hee" 1 "laugh.au") 61 ("shoot" 1 "shotgun.wav") 62 ("yawn" 1 "snore.wav") 63 ("cackle" 1 "witch.au") 64 ("yell\\|roar" 1 "yell2.au") 65 ("whoop-de-doo" 1 "whistle.au")) 66 "*A list of regexps to map earcons to real sounds." 67 :type '(repeat (list regexp 68 (integer :tag "Match") 69 (string :tag "Sound"))) 70 :group 'earcon) 71(defvar earcon-button-marker-list nil) 72(make-variable-buffer-local 'earcon-button-marker-list) 73 74;;; FIXME!! clone of code from gnus-vis.el FIXME!! 75(defun earcon-article-push-button (event) 76 "Check text under the mouse pointer for a callback function. 77If the text under the mouse pointer has a `earcon-callback' property, 78call it with the value of the `earcon-data' text property." 79 (interactive "e") 80 (set-buffer (window-buffer (posn-window (event-start event)))) 81 (let* ((pos (posn-point (event-start event))) 82 (data (get-text-property pos 'earcon-data)) 83 (fun (get-text-property pos 'earcon-callback))) 84 (if fun (funcall fun data)))) 85 86(defun earcon-article-press-button () 87 "Check text at point for a callback function. 88If the text at point has a `earcon-callback' property, 89call it with the value of the `earcon-data' text property." 90 (interactive) 91 (let* ((data (get-text-property (point) 'earcon-data)) 92 (fun (get-text-property (point) 'earcon-callback))) 93 (if fun (funcall fun data)))) 94 95(defun earcon-article-prev-button (n) 96 "Move point to N buttons backward. 97If N is negative, move forward instead." 98 (interactive "p") 99 (earcon-article-next-button (- n))) 100 101(defun earcon-article-next-button (n) 102 "Move point to N buttons forward. 103If N is negative, move backward instead." 104 (interactive "p") 105 (let ((function (if (< n 0) 'previous-single-property-change 106 'next-single-property-change)) 107 (inhibit-point-motion-hooks t) 108 (backward (< n 0)) 109 (limit (if (< n 0) (point-min) (point-max)))) 110 (setq n (abs n)) 111 (while (and (not (= limit (point))) 112 (> n 0)) 113 ;; Skip past the current button. 114 (when (get-text-property (point) 'earcon-callback) 115 (goto-char (funcall function (point) 'earcon-callback nil limit))) 116 ;; Go to the next (or previous) button. 117 (gnus-goto-char (funcall function (point) 'earcon-callback nil limit)) 118 ;; Put point at the start of the button. 119 (when (and backward (not (get-text-property (point) 'earcon-callback))) 120 (goto-char (funcall function (point) 'earcon-callback nil limit))) 121 ;; Skip past intangible buttons. 122 (when (get-text-property (point) 'intangible) 123 (incf n)) 124 (decf n)) 125 (unless (zerop n) 126 (gnus-message 5 "No more buttons")) 127 n)) 128 129(defun earcon-article-add-button (from to fun &optional data) 130 "Create a button between FROM and TO with callback FUN and data DATA." 131 (and (boundp gnus-article-button-face) 132 gnus-article-button-face 133 (gnus-overlay-put (gnus-make-overlay from to) 134 'face gnus-article-button-face)) 135 (gnus-add-text-properties 136 from to 137 (nconc (and gnus-article-mouse-face 138 (list gnus-mouse-face-prop gnus-article-mouse-face)) 139 (list 'gnus-callback fun) 140 (and data (list 'gnus-data data))))) 141 142(defun earcon-button-entry () 143 ;; Return the first entry in `gnus-button-alist' matching this place. 144 (let ((alist earcon-regexp-alist) 145 (case-fold-search t) 146 (entry nil)) 147 (while alist 148 (setq entry (pop alist)) 149 (if (looking-at (car entry)) 150 (setq alist nil) 151 (setq entry nil))) 152 entry)) 153 154(defun earcon-button-push (marker) 155 ;; Push button starting at MARKER. 156 (save-excursion 157 (set-buffer gnus-article-buffer) 158 (goto-char marker) 159 (let* ((entry (earcon-button-entry)) 160 (inhibit-point-motion-hooks t) 161 (fun 'gnus-audio-play) 162 (args (list (nth 2 entry)))) 163 (cond 164 ((fboundp fun) 165 (apply fun args)) 166 ((and (boundp fun) 167 (fboundp (symbol-value fun))) 168 (apply (symbol-value fun) args)) 169 (t 170 (gnus-message 1 "You must define `%S' to use this button" 171 (cons fun args))))))) 172 173;;; FIXME!! clone of code from gnus-vis.el FIXME!! 174 175;;;###interactive 176(defun earcon-region (beg end) 177 "Play Sounds in the region between point and mark." 178 (interactive "r") 179 (earcon-buffer (current-buffer) beg end)) 180 181;;;###interactive 182(defun earcon-buffer (&optional buffer st nd) 183 (interactive) 184 (save-excursion 185 ;; clear old markers. 186 (if (boundp 'earcon-button-marker-list) 187 (while earcon-button-marker-list 188 (set-marker (pop earcon-button-marker-list) nil)) 189 (setq earcon-button-marker-list nil)) 190 (and buffer (set-buffer buffer)) 191 (let ((buffer-read-only nil) 192 (inhibit-point-motion-hooks t) 193 (case-fold-search t) 194 (alist earcon-regexp-alist) 195 beg entry regexp) 196 (goto-char (point-min)) 197 (setq beg (point)) 198 (while (setq entry (pop alist)) 199 (setq regexp (concat (regexp-quote earcon-prefix) 200 ".*\\(" 201 (car entry) 202 "\\).*" 203 (regexp-quote earcon-suffix))) 204 (goto-char beg) 205 (while (re-search-forward regexp nil t) 206 (let* ((start (and entry (match-beginning 1))) 207 (end (and entry (match-end 1))) 208 (from (match-beginning 1))) 209 (earcon-article-add-button 210 start end 'earcon-button-push 211 (car (push (set-marker (make-marker) from) 212 earcon-button-marker-list))) 213 (gnus-audio-play (caddr entry)))))))) 214 215;;;###autoload 216(defun gnus-earcon-display () 217 "Play sounds in message buffers." 218 (interactive) 219 (save-excursion 220 (set-buffer gnus-article-buffer) 221 (goto-char (point-min)) 222 ;; Skip headers 223 (unless (search-forward "\n\n" nil t) 224 (goto-char (point-max))) 225 (sit-for 0) 226 (earcon-buffer (current-buffer) (point)))) 227 228;;;*** 229 230(provide 'earcon) 231 232(run-hooks 'earcon-load-hook) 233 234;;; arch-tag: 844dfeea-980c-4ed0-907f-a30bf139691c 235;;; earcon.el ends here 236