Mercurial > hg > xemacs-beta

comparison lisp/gnus/earcon.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents ec9a17fef872
children 0d2f883870bc
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
28 28
29 (if (null (boundp 'running-xemacs)) 29 (if (null (boundp 'running-xemacs))
30 (defvar running-xemacs (string-match "XEmacs\\|Lucid" emacs-version))) 30 (defvar running-xemacs (string-match "XEmacs\\|Lucid" emacs-version)))
31 31
32 (require 'gnus) 32 (require 'gnus)
33 (require 'gnus-audio) 33 (require 'gnus-sound)
34 (require 'gnus-art)
35 (eval-when-compile (require 'cl)) 34 (eval-when-compile (require 'cl))
36 35
37 (defgroup earcon nil 36 (defvar earcon-auto-play nil
38 "Turn ** sounds ** into noise." 37 "When True, automatially play sounds as well as buttonize them.")
39 :group 'gnus-visual) 38
40 39 (defvar earcon-prefix "**"
41 (defcustom earcon-auto-play nil 40 "The start of an earcon")
42 "When True, automatically play sounds as well as buttonize them." 41
43 :type 'boolean 42 (defvar earcon-suffix "**"
44 :group 'earcon) 43 "The end of an earcon")
45 44
46 (defcustom earcon-prefix "**" 45 (defvar earcon-regexp-alist
47 "String denoting the start of an earcon."
48 :type 'string
49 :group 'earcon)
50
51 (defcustom earcon-suffix "**"
52 "String denoting the end of an earcon."
53 :type 'string
54 :group 'earcon)
55
56 (defcustom earcon-regexp-alist
57 '(("boring" 1 "Boring.au") 46 '(("boring" 1 "Boring.au")
58 ("evil[ \t]+laugh" 1 "Evil_Laugh.au") 47 ("evil[ \t]+laugh" 1 "Evil_Laugh.au")
59 ("gag\\|puke" 1 "Puke.au") 48 ("gag\\|puke" 1 "Puke.au")
60 ("snicker" 1 "Snicker.au") 49 ("snicker" 1 "Snicker.au")
61 ("meow" 1 "catmeow.au") 50 ("meow" 1 "catmeow.au")
62 ("sob\\|boohoo" 1 "cry.wav") 51 ("sob\\|boohoo" 1 "cry.wav")
63 ("drum[ \t]*roll" 1 "drumroll.au") 52 ("drum[ \t]*roll" 1 "drumroll.au")
64 ("blast" 1 "explosion.au") 53 ("blast" 1 "explosion.au")
65 ("flush\\|plonk!*" 1 "flush.au") 54 ("flush" 1 "flush.au")
66 ("kiss" 1 "kiss.wav") 55 ("kiss" 1 "kiss.wav")
67 ("tee[ \t]*hee" 1 "laugh.au") 56 ("tee[ \t]*hee" 1 "laugh.au")
68 ("shoot" 1 "shotgun.wav") 57 ("shoot" 1 "shotgun.wav")
69 ("yawn" 1 "snore.wav") 58 ("yawn" 1 "snore.wav")
70 ("cackle" 1 "witch.au") 59 ("cackle" 1 "witch.au")
71 ("yell\\|roar" 1 "yell2.au") 60 ("yell\\|roar" 1 "yell2.au")
72 ("whoop-de-doo" 1 "whistle.au")) 61 ("whoop-de-doo" 1 "whistle.au"))
73 "A list of regexps to map earcons to real sounds." 62 "A list of regexps to map earcons to real sounds.")
74 :type '(repeat (list regexp
75 (integer :tag "Match")
76 (string :tag "Sound")))
77 :group 'earcon)
78 63
79 (defvar earcon-button-marker-list nil) 64 (defvar earcon-button-marker-list nil)
80 (make-variable-buffer-local 'earcon-button-marker-list) 65 (make-variable-buffer-local 'earcon-button-marker-list)
81 66
82 67
140 "Create a button between FROM and TO with callback FUN and data DATA." 125 "Create a button between FROM and TO with callback FUN and data DATA."
141 (and (boundp gnus-article-button-face) 126 (and (boundp gnus-article-button-face)
142 gnus-article-button-face 127 gnus-article-button-face
143 (gnus-overlay-put (gnus-make-overlay from to) 128 (gnus-overlay-put (gnus-make-overlay from to)
144 'face gnus-article-button-face)) 129 'face gnus-article-button-face))
145 (gnus-add-text-properties 130 (gnus-add-text-properties
146 from to 131 from to
147 (nconc (and gnus-article-mouse-face 132 (nconc (and gnus-article-mouse-face
148 (list gnus-mouse-face-prop gnus-article-mouse-face)) 133 (list gnus-mouse-face-prop gnus-article-mouse-face))
149 (list 'gnus-callback fun) 134 (list 'gnus-callback fun)
150 (and data (list 'gnus-data data))))) 135 (and data (list 'gnus-data data)))))
167 (save-excursion 152 (save-excursion
168 (set-buffer gnus-article-buffer) 153 (set-buffer gnus-article-buffer)
169 (goto-char marker) 154 (goto-char marker)
170 (let* ((entry (earcon-button-entry)) 155 (let* ((entry (earcon-button-entry))
171 (inhibit-point-motion-hooks t) 156 (inhibit-point-motion-hooks t)
172 (fun 'gnus-audio-play) 157 (fun 'gnus-sound-play)
173 (args (list (nth 2 entry)))) 158 (args (list (nth 2 entry))))
174 (cond 159 (cond
175 ((fboundp fun) 160 ((fboundp fun)
176 (apply fun args)) 161 (apply fun args))
177 ((and (boundp fun) 162 ((and (boundp fun)
206 beg entry regexp) 191 beg entry regexp)
207 (goto-char (point-min)) 192 (goto-char (point-min))
208 (setq beg (point)) 193 (setq beg (point))
209 (while (setq entry (pop alist)) 194 (while (setq entry (pop alist))
210 (setq regexp (concat (regexp-quote earcon-prefix) 195 (setq regexp (concat (regexp-quote earcon-prefix)
211 ".*\\(" 196 ".*\\("
212 (car entry) 197 (car entry)
213 "\\).*" 198 "\\).*"
214 (regexp-quote earcon-suffix))) 199 (regexp-quote earcon-suffix)))
215 (goto-char beg) 200 (goto-char beg)
216 (while (re-search-forward regexp nil t) 201 (while (re-search-forward regexp nil t)
217 (let* ((start (and entry (match-beginning 1))) 202 (let* ((start (and entry (match-beginning 1)))
218 (end (and entry (match-end 1))) 203 (end (and entry (match-end 1)))
219 (from (match-beginning 1))) 204 (from (match-beginning 1)))
220 (earcon-article-add-button 205 (earcon-article-add-button
221 start end 'earcon-button-push 206 start end 'earcon-button-push
222 (car (push (set-marker (make-marker) from) 207 (car (push (set-marker (make-marker) from)
223 earcon-button-marker-list))) 208 earcon-button-marker-list)))
224 (gnus-audio-play (caddr entry)))))))) 209 (gnus-sound-play (caddr entry))))))))
225 210
226 ;;;###autoload 211 ;;;###autoload
227 (defun gnus-earcon-display () 212 (defun gnus-earcon-display ()
228 "Play sounds in message buffers." 213 "Play sounds in message buffers."
229 (interactive) 214 (interactive)