Initial revision

lisp/gnus/earcon.el

+;;; 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

lisp/gnus/gnus-async.el

+;;; 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

lisp/gnus/gnus-audio.el

+;;; 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