Mercurial > emacs
annotate lisp/gnus/earcon.el @ 97095:61de98ebc619
** mairix.el is an interface to mairix, a free tool for indexing and
searching locally stored mail. It allows you to query mairix and
display the search results with Rmail, Gnus and VM. Note that there
is an existing Gnus back end, nnmairix.el, which should be used with
Maildir/MH setups.
author | Chong Yidong <cyd@stupidchicken.com> |
---|---|
date | Tue, 29 Jul 2008 17:44:00 +0000 |
parents | f42ef85caf91 |
children | a9dc0e7c3f2b |
rev | line source |
---|---|
56927
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
1 ;;; earcon.el --- Sound effects for messages |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24356
diff
changeset
|
2 |
64754
fafd692d1e40
Update years in copyright notice; nfc.
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
64085
diff
changeset
|
3 ;; Copyright (C) 1996, 2000, 2001, 2002, 2003, 2004, |
79708 | 4 ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. |
17493 | 5 |
6 ;; Author: Steven L. Baur <steve@miranova.com> | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24356
diff
changeset
|
7 |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24356
diff
changeset
|
8 ;; This file is part of GNU Emacs. |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24356
diff
changeset
|
9 |
94662
f42ef85caf91
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
93975
diff
changeset
|
10 ;; GNU Emacs is free software: you can redistribute it and/or modify |
17493 | 11 ;; it under the terms of the GNU General Public License as published by |
94662
f42ef85caf91
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
93975
diff
changeset
|
12 ;; the Free Software Foundation, either version 3 of the License, or |
f42ef85caf91
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
93975
diff
changeset
|
13 ;; (at your option) any later version. |
17493 | 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 | |
94662
f42ef85caf91
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
93975
diff
changeset
|
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
17493 | 22 |
23 ;;; Commentary: | |
24 ;; This file provides access to sound effects in Gnus. | |
25 | |
26 ;;; Code: | |
27 | |
19600
5d6dd68d8889
Require cl at compile time before loading gnus, etc.
Kenichi Handa <handa@m17n.org>
parents:
17493
diff
changeset
|
28 (eval-when-compile (require 'cl)) |
17493 | 29 (require 'gnus) |
30 (require 'gnus-audio) | |
31 (require 'gnus-art) | |
32 | |
33 (defgroup earcon nil | |
34 "Turn ** sounds ** into noise." | |
35 :group 'gnus-visual) | |
36 | |
37 (defcustom earcon-prefix "**" | |
24356
a5a611ef40f6
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19600
diff
changeset
|
38 "*String denoting the start of an earcon." |
17493 | 39 :type 'string |
40 :group 'earcon) | |
41 | |
42 (defcustom earcon-suffix "**" | |
43 "String denoting the end of an earcon." | |
44 :type 'string | |
45 :group 'earcon) | |
46 | |
47 (defcustom earcon-regexp-alist | |
48 '(("boring" 1 "Boring.au") | |
49 ("evil[ \t]+laugh" 1 "Evil_Laugh.au") | |
50 ("gag\\|puke" 1 "Puke.au") | |
51 ("snicker" 1 "Snicker.au") | |
56927
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
52 ("meow" 1 "catmeow.wav") |
17493 | 53 ("sob\\|boohoo" 1 "cry.wav") |
54 ("drum[ \t]*roll" 1 "drumroll.au") | |
55 ("blast" 1 "explosion.au") | |
56 ("flush\\|plonk!*" 1 "flush.au") | |
57 ("kiss" 1 "kiss.wav") | |
58 ("tee[ \t]*hee" 1 "laugh.au") | |
59 ("shoot" 1 "shotgun.wav") | |
60 ("yawn" 1 "snore.wav") | |
61 ("cackle" 1 "witch.au") | |
62 ("yell\\|roar" 1 "yell2.au") | |
63 ("whoop-de-doo" 1 "whistle.au")) | |
24356
a5a611ef40f6
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19600
diff
changeset
|
64 "*A list of regexps to map earcons to real sounds." |
17493 | 65 :type '(repeat (list regexp |
66 (integer :tag "Match") | |
67 (string :tag "Sound"))) | |
68 :group 'earcon) | |
69 (defvar earcon-button-marker-list nil) | |
70 (make-variable-buffer-local 'earcon-button-marker-list) | |
71 | |
72 ;;; FIXME!! clone of code from gnus-vis.el FIXME!! | |
73 (defun earcon-article-push-button (event) | |
74 "Check text under the mouse pointer for a callback function. | |
75 If the text under the mouse pointer has a `earcon-callback' property, | |
76 call it with the value of the `earcon-data' text property." | |
77 (interactive "e") | |
78 (set-buffer (window-buffer (posn-window (event-start event)))) | |
79 (let* ((pos (posn-point (event-start event))) | |
56927
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
80 (data (get-text-property pos 'earcon-data)) |
17493 | 81 (fun (get-text-property pos 'earcon-callback))) |
82 (if fun (funcall fun data)))) | |
83 | |
84 (defun earcon-article-press-button () | |
85 "Check text at point for a callback function. | |
86 If the text at point has a `earcon-callback' property, | |
87 call it with the value of the `earcon-data' text property." | |
88 (interactive) | |
89 (let* ((data (get-text-property (point) 'earcon-data)) | |
90 (fun (get-text-property (point) 'earcon-callback))) | |
91 (if fun (funcall fun data)))) | |
92 | |
93 (defun earcon-article-prev-button (n) | |
94 "Move point to N buttons backward. | |
95 If N is negative, move forward instead." | |
96 (interactive "p") | |
97 (earcon-article-next-button (- n))) | |
98 | |
99 (defun earcon-article-next-button (n) | |
100 "Move point to N buttons forward. | |
101 If N is negative, move backward instead." | |
102 (interactive "p") | |
103 (let ((function (if (< n 0) 'previous-single-property-change | |
104 'next-single-property-change)) | |
105 (inhibit-point-motion-hooks t) | |
106 (backward (< n 0)) | |
107 (limit (if (< n 0) (point-min) (point-max)))) | |
108 (setq n (abs n)) | |
109 (while (and (not (= limit (point))) | |
110 (> n 0)) | |
111 ;; Skip past the current button. | |
112 (when (get-text-property (point) 'earcon-callback) | |
113 (goto-char (funcall function (point) 'earcon-callback nil limit))) | |
114 ;; Go to the next (or previous) button. | |
115 (gnus-goto-char (funcall function (point) 'earcon-callback nil limit)) | |
116 ;; Put point at the start of the button. | |
117 (when (and backward (not (get-text-property (point) 'earcon-callback))) | |
118 (goto-char (funcall function (point) 'earcon-callback nil limit))) | |
119 ;; Skip past intangible buttons. | |
120 (when (get-text-property (point) 'intangible) | |
121 (incf n)) | |
122 (decf n)) | |
123 (unless (zerop n) | |
124 (gnus-message 5 "No more buttons")) | |
125 n)) | |
126 | |
127 (defun earcon-article-add-button (from to fun &optional data) | |
128 "Create a button between FROM and TO with callback FUN and data DATA." | |
129 (and (boundp gnus-article-button-face) | |
130 gnus-article-button-face | |
131 (gnus-overlay-put (gnus-make-overlay from to) | |
132 'face gnus-article-button-face)) | |
133 (gnus-add-text-properties | |
134 from to | |
135 (nconc (and gnus-article-mouse-face | |
136 (list gnus-mouse-face-prop gnus-article-mouse-face)) | |
137 (list 'gnus-callback fun) | |
138 (and data (list 'gnus-data data))))) | |
139 | |
140 (defun earcon-button-entry () | |
141 ;; Return the first entry in `gnus-button-alist' matching this place. | |
142 (let ((alist earcon-regexp-alist) | |
143 (case-fold-search t) | |
144 (entry nil)) | |
145 (while alist | |
146 (setq entry (pop alist)) | |
147 (if (looking-at (car entry)) | |
148 (setq alist nil) | |
149 (setq entry nil))) | |
150 entry)) | |
151 | |
152 (defun earcon-button-push (marker) | |
153 ;; Push button starting at MARKER. | |
154 (save-excursion | |
155 (set-buffer gnus-article-buffer) | |
156 (goto-char marker) | |
157 (let* ((entry (earcon-button-entry)) | |
158 (inhibit-point-motion-hooks t) | |
159 (fun 'gnus-audio-play) | |
160 (args (list (nth 2 entry)))) | |
161 (cond | |
162 ((fboundp fun) | |
163 (apply fun args)) | |
164 ((and (boundp fun) | |
165 (fboundp (symbol-value fun))) | |
166 (apply (symbol-value fun) args)) | |
167 (t | |
168 (gnus-message 1 "You must define `%S' to use this button" | |
169 (cons fun args))))))) | |
170 | |
171 ;;; FIXME!! clone of code from gnus-vis.el FIXME!! | |
172 | |
173 ;;;###interactive | |
174 (defun earcon-region (beg end) | |
175 "Play Sounds in the region between point and mark." | |
176 (interactive "r") | |
177 (earcon-buffer (current-buffer) beg end)) | |
178 | |
179 ;;;###interactive | |
180 (defun earcon-buffer (&optional buffer st nd) | |
181 (interactive) | |
182 (save-excursion | |
183 ;; clear old markers. | |
184 (if (boundp 'earcon-button-marker-list) | |
185 (while earcon-button-marker-list | |
186 (set-marker (pop earcon-button-marker-list) nil)) | |
187 (setq earcon-button-marker-list nil)) | |
188 (and buffer (set-buffer buffer)) | |
189 (let ((buffer-read-only nil) | |
190 (inhibit-point-motion-hooks t) | |
191 (case-fold-search t) | |
192 (alist earcon-regexp-alist) | |
193 beg entry regexp) | |
194 (goto-char (point-min)) | |
195 (setq beg (point)) | |
196 (while (setq entry (pop alist)) | |
197 (setq regexp (concat (regexp-quote earcon-prefix) | |
198 ".*\\(" | |
199 (car entry) | |
200 "\\).*" | |
201 (regexp-quote earcon-suffix))) | |
202 (goto-char beg) | |
203 (while (re-search-forward regexp nil t) | |
204 (let* ((start (and entry (match-beginning 1))) | |
205 (end (and entry (match-end 1))) | |
206 (from (match-beginning 1))) | |
207 (earcon-article-add-button | |
208 start end 'earcon-button-push | |
209 (car (push (set-marker (make-marker) from) | |
210 earcon-button-marker-list))) | |
211 (gnus-audio-play (caddr entry)))))))) | |
212 | |
213 ;;;###autoload | |
214 (defun gnus-earcon-display () | |
215 "Play sounds in message buffers." | |
216 (interactive) | |
217 (save-excursion | |
218 (set-buffer gnus-article-buffer) | |
219 (goto-char (point-min)) | |
220 ;; Skip headers | |
221 (unless (search-forward "\n\n" nil t) | |
222 (goto-char (point-max))) | |
223 (sit-for 0) | |
224 (earcon-buffer (current-buffer) (point)))) | |
225 | |
226 ;;;*** | |
227 | |
228 (provide 'earcon) | |
229 | |
230 (run-hooks 'earcon-load-hook) | |
231 | |
93975
1e3a407766b9
Fix up comment convention on the arch-tag lines.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
79708
diff
changeset
|
232 ;; arch-tag: 844dfeea-980c-4ed0-907f-a30bf139691c |
17493 | 233 ;;; earcon.el ends here |