Initial revision

parent efac8cf1
;;; earcon.el --- Sound effects for messages
;; Copyright (C) 1996 Free Software Foundation
;; Author: Steven L. Baur <steve@miranova.com>
;; Keywords: news fun sound
;; 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., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; This file provides access to sound effects in Gnus.
;;; Code:
(if (null (boundp 'running-xemacs))
(defvar running-xemacs (string-match "XEmacs\\|Lucid" emacs-version)))
(require 'gnus)
(require 'gnus-audio)
(require 'gnus-art)
(eval-when-compile (require 'cl))
(defgroup earcon nil
"Turn ** sounds ** into noise."
:group 'gnus-visual)
(defcustom earcon-auto-play nil
"When True, automatically play sounds as well as buttonize them."
:type 'boolean
:group 'earcon)
(defcustom earcon-prefix "**"
"String denoting the start of an earcon."
:type 'string
:group 'earcon)
(defcustom earcon-suffix "**"
"String denoting the end of an earcon."
:type 'string
:group 'earcon)
(defcustom earcon-regexp-alist
'(("boring" 1 "Boring.au")
("evil[ \t]+laugh" 1 "Evil_Laugh.au")
("gag\\|puke" 1 "Puke.au")
("snicker" 1 "Snicker.au")
("meow" 1 "catmeow.au")
("sob\\|boohoo" 1 "cry.wav")
("drum[ \t]*roll" 1 "drumroll.au")
("blast" 1 "explosion.au")
("flush\\|plonk!*" 1 "flush.au")
("kiss" 1 "kiss.wav")
("tee[ \t]*hee" 1 "laugh.au")
("shoot" 1 "shotgun.wav")
("yawn" 1 "snore.wav")
("cackle" 1 "witch.au")
("yell\\|roar" 1 "yell2.au")
("whoop-de-doo" 1 "whistle.au"))
"A list of regexps to map earcons to real sounds."
:type '(repeat (list regexp
(integer :tag "Match")
(string :tag "Sound")))
:group 'earcon)
(defvar earcon-button-marker-list nil)
(make-variable-buffer-local 'earcon-button-marker-list)
;;; FIXME!! clone of code from gnus-vis.el FIXME!!
(defun earcon-article-push-button (event)
"Check text under the mouse pointer for a callback function.
If the text under the mouse pointer has a `earcon-callback' property,
call it with the value of the `earcon-data' text property."
(interactive "e")
(set-buffer (window-buffer (posn-window (event-start event))))
(let* ((pos (posn-point (event-start event)))
(data (get-text-property pos 'earcon-data))
(fun (get-text-property pos 'earcon-callback)))
(if fun (funcall fun data))))
(defun earcon-article-press-button ()
"Check text at point for a callback function.
If the text at point has a `earcon-callback' property,
call it with the value of the `earcon-data' text property."
(interactive)
(let* ((data (get-text-property (point) 'earcon-data))
(fun (get-text-property (point) 'earcon-callback)))
(if fun (funcall fun data))))
(defun earcon-article-prev-button (n)
"Move point to N buttons backward.
If N is negative, move forward instead."
(interactive "p")
(earcon-article-next-button (- n)))
(defun earcon-article-next-button (n)
"Move point to N buttons forward.
If N is negative, move backward instead."
(interactive "p")
(let ((function (if (< n 0) 'previous-single-property-change
'next-single-property-change))
(inhibit-point-motion-hooks t)
(backward (< n 0))
(limit (if (< n 0) (point-min) (point-max))))
(setq n (abs n))
(while (and (not (= limit (point)))
(> n 0))
;; Skip past the current button.
(when (get-text-property (point) 'earcon-callback)
(goto-char (funcall function (point) 'earcon-callback nil limit)))
;; Go to the next (or previous) button.
(gnus-goto-char (funcall function (point) 'earcon-callback nil limit))
;; Put point at the start of the button.
(when (and backward (not (get-text-property (point) 'earcon-callback)))
(goto-char (funcall function (point) 'earcon-callback nil limit)))
;; Skip past intangible buttons.
(when (get-text-property (point) 'intangible)
(incf n))
(decf n))
(unless (zerop n)
(gnus-message 5 "No more buttons"))
n))
(defun earcon-article-add-button (from to fun &optional data)
"Create a button between FROM and TO with callback FUN and data DATA."
(and (boundp gnus-article-button-face)
gnus-article-button-face
(gnus-overlay-put (gnus-make-overlay from to)
'face gnus-article-button-face))
(gnus-add-text-properties
from to
(nconc (and gnus-article-mouse-face
(list gnus-mouse-face-prop gnus-article-mouse-face))
(list 'gnus-callback fun)
(and data (list 'gnus-data data)))))
(defun earcon-button-entry ()
;; Return the first entry in `gnus-button-alist' matching this place.
(let ((alist earcon-regexp-alist)
(case-fold-search t)
(entry nil))
(while alist
(setq entry (pop alist))
(if (looking-at (car entry))
(setq alist nil)
(setq entry nil)))
entry))
(defun earcon-button-push (marker)
;; Push button starting at MARKER.
(save-excursion
(set-buffer gnus-article-buffer)
(goto-char marker)
(let* ((entry (earcon-button-entry))
(inhibit-point-motion-hooks t)
(fun 'gnus-audio-play)
(args (list (nth 2 entry))))
(cond
((fboundp fun)
(apply fun args))
((and (boundp fun)
(fboundp (symbol-value fun)))
(apply (symbol-value fun) args))
(t
(gnus-message 1 "You must define `%S' to use this button"
(cons fun args)))))))
;;; FIXME!! clone of code from gnus-vis.el FIXME!!
;;;###interactive
(defun earcon-region (beg end)
"Play Sounds in the region between point and mark."
(interactive "r")
(earcon-buffer (current-buffer) beg end))
;;;###interactive
(defun earcon-buffer (&optional buffer st nd)
(interactive)
(save-excursion
;; clear old markers.
(if (boundp 'earcon-button-marker-list)
(while earcon-button-marker-list
(set-marker (pop earcon-button-marker-list) nil))
(setq earcon-button-marker-list nil))
(and buffer (set-buffer buffer))
(let ((buffer-read-only nil)
(inhibit-point-motion-hooks t)
(case-fold-search t)
(alist earcon-regexp-alist)
beg entry regexp)
(goto-char (point-min))
(setq beg (point))
(while (setq entry (pop alist))
(setq regexp (concat (regexp-quote earcon-prefix)
".*\\("
(car entry)
"\\).*"
(regexp-quote earcon-suffix)))
(goto-char beg)
(while (re-search-forward regexp nil t)
(let* ((start (and entry (match-beginning 1)))
(end (and entry (match-end 1)))
(from (match-beginning 1)))
(earcon-article-add-button
start end 'earcon-button-push
(car (push (set-marker (make-marker) from)
earcon-button-marker-list)))
(gnus-audio-play (caddr entry))))))))
;;;###autoload
(defun gnus-earcon-display ()
"Play sounds in message buffers."
(interactive)
(save-excursion
(set-buffer gnus-article-buffer)
(goto-char (point-min))
;; Skip headers
(unless (search-forward "\n\n" nil t)
(goto-char (point-max)))
(sit-for 0)
(earcon-buffer (current-buffer) (point))))
;;;***
(provide 'earcon)
(run-hooks 'earcon-load-hook)
;;; earcon.el ends here
This diff is collapsed.
;;; gnus-async.el --- asynchronous support for Gnus
;; Copyright (C) 1996,97 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Keywords: news
;; 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., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;;; Code:
(require 'gnus)
(require 'gnus-sum)
(require 'nntp)
(defgroup gnus-asynchronous nil
"Support for asynchronous operations."
:group 'gnus)
(defcustom gnus-asynchronous t
"*If nil, inhibit all Gnus asynchronicity.
If non-nil, let the other asynch variables be heeded."
:group 'gnus-asynchronous
:type 'boolean)
(defcustom gnus-use-article-prefetch 30
"*If non-nil, prefetch articles in groups that allow this.
If a number, prefetch only that many articles forward;
if t, prefetch as many articles as possible."
:group 'gnus-asynchronous
:type '(choice (const :tag "off" nil)
(const :tag "all" t)
(integer :tag "some" 0)))
(defcustom gnus-prefetched-article-deletion-strategy '(read exit)
"List of symbols that say when to remove articles from the prefetch buffer.
Possible values in this list are `read', which means that
articles are removed as they are read, and `exit', which means
that all articles belonging to a group are removed on exit
from that group."
:group 'gnus-asynchronous
:type '(set (const read) (const exit)))
(defcustom gnus-use-header-prefetch nil
"*If non-nil, prefetch the headers to the next group."
:group 'gnus-asynchronous
:type 'boolean)
(defcustom gnus-async-prefetch-article-p 'gnus-async-unread-p
"Function called to say whether an article should be prefetched or not.
The function is called with one parameter -- the article data.
It should return non-nil if the article is to be prefetched."
:group 'gnus-asynchronous
:type 'function)
;;; Internal variables.
(defvar gnus-async-prefetch-article-buffer " *Async Prefetch Article*")
(defvar gnus-async-article-alist nil)
(defvar gnus-async-article-semaphore '(nil))
(defvar gnus-async-fetch-list nil)
(defvar gnus-async-prefetch-headers-buffer " *Async Prefetch Headers*")
(defvar gnus-async-header-prefetched nil)
;;; Utility functions.
(defun gnus-group-asynchronous-p (group)
"Say whether GROUP is fetched from a server that supports asynchronicity."
(gnus-asynchronous-p (gnus-find-method-for-group group)))
;;; Somewhat bogus semaphores.
(defun gnus-async-get-semaphore (semaphore)
"Wait until SEMAPHORE is released."
(while (/= (length (nconc (symbol-value semaphore) (list nil))) 2)
(sleep-for 1)))
(defun gnus-async-release-semaphore (semaphore)
"Release SEMAPHORE."
(setcdr (symbol-value semaphore) nil))
(defmacro gnus-async-with-semaphore (&rest forms)
`(unwind-protect
(progn
(gnus-async-get-semaphore 'gnus-async-article-semaphore)
,@forms)
(gnus-async-release-semaphore 'gnus-async-article-semaphore)))
(put 'gnus-asynch-with-semaphore 'lisp-indent-function 0)
(put 'gnus-asynch-with-semaphore 'edebug-form-spec '(body))
;;;
;;; Article prefetch
;;;
(gnus-add-shutdown 'gnus-async-close 'gnus)
(defun gnus-async-close ()
(gnus-kill-buffer gnus-async-prefetch-article-buffer)
(gnus-kill-buffer gnus-async-prefetch-headers-buffer)
(setq gnus-async-article-alist nil
gnus-async-header-prefetched nil))
(defun gnus-async-set-buffer ()
(nnheader-set-temp-buffer gnus-async-prefetch-article-buffer t))
(defun gnus-async-halt-prefetch ()
"Stop prefetching."
(setq gnus-async-fetch-list nil))
(defun gnus-async-prefetch-next (group article summary)
"Possibly prefetch several articles starting with the article after ARTICLE."
(when (and (gnus-buffer-live-p summary)
gnus-asynchronous
(gnus-group-asynchronous-p group))
(save-excursion
(set-buffer gnus-summary-buffer)
(let ((next (caadr (gnus-data-find-list article))))
(when next
(if (not (fboundp 'run-with-idle-timer))
;; This is either an older Emacs or XEmacs, so we
;; do this, which leads to slightly slower article
;; buffer display.
(gnus-async-prefetch-article group next summary)
(run-with-idle-timer
0.1 nil 'gnus-async-prefetch-article group next summary)))))))
(defun gnus-async-prefetch-article (group article summary &optional next)
"Possibly prefetch several articles starting with ARTICLE."
(if (not (gnus-buffer-live-p summary))
(gnus-async-with-semaphore
(setq gnus-async-fetch-list nil))
(when (and gnus-asynchronous
(gnus-alive-p))
(when next
(gnus-async-with-semaphore
(pop gnus-async-fetch-list)))
(let ((do-fetch next)
(do-message t)) ;(eq major-mode 'gnus-summary-mode)))
(when (and (gnus-group-asynchronous-p group)
(gnus-buffer-live-p summary)
(or (not next)
gnus-async-fetch-list))
(gnus-async-with-semaphore
(unless next
(setq do-fetch (not gnus-async-fetch-list))
;; Nix out any outstanding requests.
(setq gnus-async-fetch-list nil)
;; Fill in the new list.
(let ((n gnus-use-article-prefetch)
(data (gnus-data-find-list article))
d)
(while (and (setq d (pop data))
(if (numberp n)
(natnump (decf n))
n))
(unless (or (gnus-async-prefetched-article-entry
group (setq article (gnus-data-number d)))
(not (natnump article))
(not (funcall gnus-async-prefetch-article-p d)))
;; Not already fetched -- so we add it to the list.
(push article gnus-async-fetch-list)))
(setq gnus-async-fetch-list
(nreverse gnus-async-fetch-list))))
(when do-fetch
(setq article (car gnus-async-fetch-list))))
(when (and do-fetch article)
;; We want to fetch some more articles.
(save-excursion
(set-buffer summary)
(let (mark)
(gnus-async-set-buffer)
(goto-char (point-max))
(setq mark (point-marker))
(let ((nnheader-callback-function
(gnus-make-async-article-function
group article mark summary next))
(nntp-server-buffer
(get-buffer gnus-async-prefetch-article-buffer)))
(when do-message
(gnus-message 9 "Prefetching article %d in group %s"
article group))
(gnus-request-article article group))))))))))
(defun gnus-make-async-article-function (group article mark summary next)
"Return a callback function."
`(lambda (arg)
(save-excursion
(when arg
(gnus-async-set-buffer)
(gnus-async-with-semaphore
(push (list ',(intern (format "%s-%d" group article))
,mark (set-marker (make-marker) (point-max))
,group ,article)
gnus-async-article-alist)))
(if (not (gnus-buffer-live-p ,summary))
(gnus-async-with-semaphore
(setq gnus-async-fetch-list nil))
(gnus-async-prefetch-article ,group ,next ,summary t)))))
(defun gnus-async-unread-p (data)
"Return non-nil if DATA represents an unread article."
(gnus-data-unread-p data))
(defun gnus-async-request-fetched-article (group article buffer)
"See whether we have ARTICLE from GROUP and put it in BUFFER."
(when (numberp article)
(let ((entry (gnus-async-prefetched-article-entry group article)))
(when entry
(save-excursion
(gnus-async-set-buffer)
(copy-to-buffer buffer (cadr entry) (caddr entry))
;; Remove the read article from the prefetch buffer.
(when (memq 'read gnus-prefetched-article-deletion-strategy)
(gnus-async-delete-prefected-entry entry))
t)))))
(defun gnus-async-delete-prefected-entry (entry)
"Delete ENTRY from buffer and alist."
(ignore-errors
(delete-region (cadr entry) (caddr entry))
(set-marker (cadr entry) nil)
(set-marker (caddr entry) nil))
(gnus-async-with-semaphore
(setq gnus-async-article-alist
(delq entry gnus-async-article-alist))))
(defun gnus-async-prefetch-remove-group (group)
"Remove all articles belonging to GROUP from the prefetch buffer."
(when (and (gnus-group-asynchronous-p group)
(memq 'exit gnus-prefetched-article-deletion-strategy))
(let ((alist gnus-async-article-alist))
(save-excursion
(gnus-async-set-buffer)
(while alist
(when (equal group (nth 3 (car alist)))
(gnus-async-delete-prefected-entry (car alist)))
(pop alist))))))
(defun gnus-async-prefetched-article-entry (group article)
"Return the entry for ARTICLE in GROUP iff it has been prefetched."
(let ((entry (assq (intern (format "%s-%d" group article))
gnus-async-article-alist)))
;; Perhaps something has emptied the buffer?
(if (and entry
(= (cadr entry) (caddr entry)))
(progn
(ignore-errors
(set-marker (cadr entry) nil)
(set-marker (caddr entry) nil))
(setq gnus-async-article-alist
(delq entry gnus-async-article-alist))
nil)
entry)))
;;;
;;; Header prefetch
;;;
(defun gnus-async-prefetch-headers (group)
"Prefetch the headers for group GROUP."
(save-excursion
(let (unread)
(when (and gnus-use-header-prefetch
gnus-asynchronous
(gnus-group-asynchronous-p group)
(listp gnus-async-header-prefetched)
(setq unread (gnus-list-of-unread-articles group)))
;; Mark that a fetch is in progress.
(setq gnus-async-header-prefetched t)
(nnheader-set-temp-buffer gnus-async-prefetch-headers-buffer t)
(erase-buffer)
(let ((nntp-server-buffer (current-buffer))
(nnheader-callback-function
`(lambda (arg)
(setq gnus-async-header-prefetched
,(cons group unread)))))
(gnus-retrieve-headers unread group gnus-fetch-old-headers))))))
(defun gnus-async-retrieve-fetched-headers (articles group)
"See whether we have prefetched headers."
(when (and gnus-use-header-prefetch
(gnus-group-asynchronous-p group)
(listp gnus-async-header-prefetched)
(equal group (car gnus-async-header-prefetched))
(equal articles (cdr gnus-async-header-prefetched)))
(save-excursion
(nnheader-set-temp-buffer gnus-async-prefetch-headers-buffer t)
(nntp-decode-text)
(copy-to-buffer nntp-server-buffer (point-min) (point-max))
(erase-buffer)
(setq gnus-async-header-prefetched nil)
t)))
(provide 'gnus-async)
;;; gnus-async.el ends here
;;; gnus-audio.el --- Sound effects for Gnus
;; Copyright (C) 1996 Free Software Foundation
;; Author: Steven L. Baur <steve@miranova.com>
;; Keywords: news
;; 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., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; This file provides access to sound effects in Gnus.
;; Prerelease: This file is partially stripped to support earcons.el
;; You can safely ignore most of it until Red Gnus. **Evil Laugh**
;;; Code:
(when (null (boundp 'running-xemacs))
(defvar running-xemacs (string-match "XEmacs\\|Lucid" emacs-version)))
(require 'nnheader)
(eval-when-compile (require 'cl))
(defvar gnus-audio-inline-sound
(and (fboundp 'device-sound-enabled-p)
(device-sound-enabled-p))
"When t, we will not spawn a subprocess to play sounds.")
(defvar gnus-audio-directory (nnheader-find-etc-directory "sounds")
"The directory containing the Sound Files.")
(defvar gnus-audio-au-player "/usr/bin/showaudio"
"Executable program for playing sun AU format sound files")
(defvar gnus-audio-wav-player "/usr/local/bin/play"
"Executable program for playing WAV files")
;;; The following isn't implemented yet. Wait for Red Gnus.
;(defvar gnus-audio-effects-enabled t
; "When t, Gnus will use sound effects.")
;(defvar gnus-audio-enable-hooks nil
; "Functions run when enabling sound effects.")
;(defvar gnus-audio-disable-hooks nil
; "Functions run when disabling sound effects.")
;(defvar gnus-audio-theme-song nil
; "Theme song for Gnus.")
;(defvar gnus-audio-enter-group nil
; "Sound effect played when selecting a group.")
;(defvar gnus-audio-exit-group nil