Contents of release-21-2 at 1999-07-02-10.
[chise/xemacs-chise.git.1] / src / sound.c
1 /* Sound functions.
2    Copyright (C) 1992, 1993, 1994 Lucid Inc.
3    Copyright (C) 1994, 1995 Free Software Foundation, Inc.
4
5 This file is part of XEmacs.
6
7 XEmacs is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the
9 Free Software Foundation; either version 2, or (at your option) any
10 later version.
11
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
15 for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with XEmacs; see the file COPYING.  If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA.  */
21
22 /* Synched up with: Not in FSF. */
23
24 /* Originally written by Jamie Zawinski.
25    Hacked on quite a bit by various others. */
26
27 #include <config.h>
28 #include "lisp.h"
29
30 #include "buffer.h"
31 #ifdef HAVE_X_WINDOWS
32 #include "console-x.h"
33 #endif
34
35 #include "device.h"
36 #include "redisplay.h"
37 #include "sysdep.h"
38
39 #ifdef HAVE_UNISTD_H
40 #include <unistd.h>
41 #endif
42
43 #ifdef HAVE_NATIVE_SOUND
44 # include <netdb.h>
45 #endif
46
47 int bell_volume;
48 Lisp_Object Vsound_alist;
49 Lisp_Object Vsynchronous_sounds;
50 Lisp_Object Vnative_sound_only_on_console;
51 Lisp_Object Q_volume, Q_pitch, Q_duration, Q_sound;
52
53 /* These are defined in the appropriate file (sunplay.c, sgiplay.c,
54    or hpplay.c). */
55
56 extern void play_sound_file (char *name, int volume);
57 extern void play_sound_data (unsigned char *data, int length, int volume);
58
59 #ifdef HAVE_NAS_SOUND
60 extern int nas_play_sound_file (char *name, int volume);
61 extern int nas_play_sound_data (unsigned char *data, int length, int volume);
62 extern int nas_wait_for_sounds (void);
63 extern char *nas_init_play (Display *);
64
65 Lisp_Object Qnas;
66 #endif
67
68 DEFUN ("play-sound-file", Fplay_sound_file, 1, 3, "fSound file name: ", /*
69 Play the named sound file on DEVICE's speaker at the specified volume
70 \(0-100, default specified by the `bell-volume' variable).
71 On Unix machines the sound file must be in the Sun/NeXT U-LAW format
72 except under Linux where WAV files are also supported.  On Microsoft
73 Windows the sound file must be in WAV format.
74   DEVICE defaults to the selected device.
75 */
76      (file, volume, device))
77 {
78   /* This function can call lisp */
79   int vol;
80 #if defined (HAVE_NATIVE_SOUND) || defined (HAVE_NAS_SOUND)
81   struct device *d = decode_device (device);
82 #endif
83   struct gcpro gcpro1;
84
85   CHECK_STRING (file);
86   if (NILP (volume))
87     vol = bell_volume;
88   else
89     {
90       CHECK_INT (volume);
91       vol = XINT (volume);
92     }
93
94   GCPRO1 (file);
95   while (1)
96     {
97       file = Fexpand_file_name (file, Qnil);
98       if (!NILP(Ffile_readable_p (file)))
99         break;
100       else
101         {
102           /* #### This is crockish.  It might be a better idea to try
103              to open the file, and use report_file_error() if it
104              fails.  --hniksic */
105           if (NILP (Ffile_exists_p (file)))
106             file =
107               signal_simple_continuable_error ("File does not exist", file);
108           else
109             file =
110               signal_simple_continuable_error ("File is unreadable", file);
111         }
112     }
113   UNGCPRO;
114
115 #ifdef HAVE_NAS_SOUND
116   if (DEVICE_CONNECTED_TO_NAS_P (d))
117     {
118       char *fileext;
119
120       GET_C_STRING_FILENAME_DATA_ALLOCA (file, fileext);
121       /* #### NAS code should allow specification of a device. */
122       if (nas_play_sound_file (fileext, vol))
123         return Qnil;
124     }
125 #endif /* HAVE_NAS_SOUND */
126
127 #ifdef HAVE_NATIVE_SOUND
128   if (NILP (Vnative_sound_only_on_console) || DEVICE_ON_CONSOLE_P (d))
129     {
130       CONST char *fileext;
131
132       GET_C_STRING_FILENAME_DATA_ALLOCA (file, fileext);
133       /* The sound code doesn't like getting SIGIO interrupts.
134          Unix sucks! */
135       stop_interrupts ();
136       play_sound_file ((char *) fileext, vol);
137       start_interrupts ();
138       QUIT;
139     }
140 #endif /* HAVE_NATIVE_SOUND */
141
142   return Qnil;
143 }
144
145 static void
146 parse_sound_alist_elt (Lisp_Object elt,
147                        Lisp_Object *volume,
148                        Lisp_Object *pitch,
149                        Lisp_Object *duration,
150                        Lisp_Object *sound)
151 {
152   *volume = Qnil;
153   *pitch = Qnil;
154   *duration = Qnil;
155   *sound = Qnil;
156   if (! CONSP (elt))
157     return;
158
159   /* The things we do for backward compatibility...
160      I wish I had just forced this to be a plist to begin with.
161    */
162
163   if (SYMBOLP (elt) || STRINGP (elt))           /* ( name . <sound> ) */
164     {
165       *sound = elt;
166     }
167   else if (!CONSP (elt))
168     {
169       return;
170     }
171   else if (NILP (XCDR (elt)) &&         /* ( name <sound> ) */
172            (SYMBOLP (XCAR (elt)) ||
173             STRINGP (XCAR (elt))))
174     {
175       *sound = XCAR (elt);
176     }
177   else if (INT_OR_FLOATP (XCAR (elt)) &&        /* ( name <vol> . <sound> ) */
178            (SYMBOLP (XCDR (elt)) ||
179             STRINGP (XCDR (elt))))
180     {
181       *volume = XCAR (elt);
182       *sound = XCDR (elt);
183     }
184   else if (INT_OR_FLOATP (XCAR (elt)) &&        /* ( name <vol> <sound> ) */
185            CONSP (XCDR (elt)) &&
186            NILP (XCDR (XCDR (elt))) &&
187            (SYMBOLP (XCAR (XCDR (elt))) ||
188             STRINGP (XCAR (XCDR (elt)))))
189     {
190       *volume = XCAR (elt);
191       *sound = XCAR (XCDR (elt));
192     }
193   else if ((SYMBOLP (XCAR (elt)) ||     /* ( name <sound> . <vol> ) */
194             STRINGP (XCAR (elt))) &&
195            INT_OR_FLOATP (XCDR (elt)))
196     {
197       *sound = XCAR (elt);
198       *volume = XCDR (elt);
199     }
200 #if 0 /* this one is ambiguous with the plist form */
201   else if ((SYMBOLP (XCAR (elt)) ||     /* ( name <sound> <vol> ) */
202             STRINGP (XCAR (elt))) &&
203            CONSP (XCDR (elt)) &&
204            NILP (XCDR (XCDR (elt))) &&
205            INT_OR_FLOATP (XCAR (XCDR (elt))))
206     {
207       *sound = XCAR (elt);
208       *volume = XCAR (XCDR (elt));
209     }
210 #endif /* 0 */
211   else                                  /* ( name [ keyword <value> ]* ) */
212     {
213       while (CONSP (elt))
214         {
215           Lisp_Object key, val;
216           key = XCAR (elt);
217           val = XCDR (elt);
218           if (!CONSP (val))
219             return;
220           elt = XCDR (val);
221           val = XCAR (val);
222           if (EQ (key, Q_volume))
223             {
224               if (INT_OR_FLOATP (val)) *volume = val;
225             }
226           else if (EQ (key, Q_pitch))
227             {
228               if (INT_OR_FLOATP (val)) *pitch = val;
229               if (NILP (*sound)) *sound = Qt;
230             }
231           else if (EQ (key, Q_duration))
232             {
233               if (INT_OR_FLOATP (val)) *duration = val;
234               if (NILP (*sound)) *sound = Qt;
235             }
236           else if (EQ (key, Q_sound))
237             {
238               if (SYMBOLP (val) || STRINGP (val)) *sound = val;
239             }
240         }
241     }
242 }
243
244 DEFUN ("play-sound", Fplay_sound, 1, 3, 0, /*
245 Play a sound of the provided type.
246 See the variable `sound-alist'.
247 */
248        (sound, volume, device))
249 {
250   int looking_for_default = 0;
251   /* variable `sound' is anything that can be a cdr in sound-alist */
252   Lisp_Object new_volume, pitch, duration, data;
253   int loop_count = 0;
254   int vol, pit, dur;
255   struct device *d = decode_device (device);
256
257   /* NOTE!  You'd better not signal an error in here. */
258
259
260  try_it_again:
261   while (1)
262     {
263       if (SYMBOLP (sound))
264         sound = Fcdr (Fassq (sound, Vsound_alist));
265       parse_sound_alist_elt (sound, &new_volume, &pitch, &duration, &data);
266       sound = data;
267       if (NILP (volume)) volume = new_volume;
268       if (EQ (sound, Qt) || EQ (sound, Qnil) || STRINGP (sound))
269         break;
270       if (loop_count++ > 500)   /* much bogosity has occurred */
271         break;
272     }
273
274   if (NILP (sound) && !looking_for_default)
275     {
276       looking_for_default = 1;
277       loop_count = 0;
278       sound = Qdefault;
279       goto try_it_again;
280     }
281
282
283   vol = (INT_OR_FLOATP (volume)   ? (int) XFLOATINT (volume)   : bell_volume);
284   pit = (INT_OR_FLOATP (pitch)    ? (int) XFLOATINT (pitch)    : -1);
285   dur = (INT_OR_FLOATP (duration) ? (int) XFLOATINT (duration) : -1);
286
287   /* If the sound is a string, and we're connected to Nas, do that.
288      Else if the sound is a string, and we're on console, play it natively.
289      Else just beep.
290    */
291 #ifdef HAVE_NAS_SOUND
292   if (DEVICE_CONNECTED_TO_NAS_P (d) && STRINGP (sound))
293     {
294       CONST Extbyte *soundext;
295       Extcount soundextlen;
296
297       GET_STRING_BINARY_DATA_ALLOCA (sound, soundext, soundextlen);
298       if (nas_play_sound_data ((unsigned char*)soundext, soundextlen, vol))
299         return Qnil;
300     }
301 #endif /* HAVE_NAS_SOUND */
302
303 #ifdef HAVE_NATIVE_SOUND
304   if ((NILP (Vnative_sound_only_on_console) || DEVICE_ON_CONSOLE_P (d))
305       && STRINGP (sound))
306     {
307       CONST Extbyte *soundext;
308       Extcount soundextlen;
309
310       GET_STRING_BINARY_DATA_ALLOCA (sound, soundext, soundextlen);
311       /* The sound code doesn't like getting SIGIO interrupts. Unix sucks! */
312       stop_interrupts ();
313       play_sound_data ((unsigned char*)soundext, soundextlen, vol);
314       start_interrupts ();
315       QUIT;
316       return Qnil;
317     }
318 #endif  /* HAVE_NATIVE_SOUND */
319
320   DEVMETH (d, ring_bell, (d, vol, pit, dur));
321   return Qnil;
322 }
323
324 DEFUN ("device-sound-enabled-p", Fdevice_sound_enabled_p, 0, 1, 0, /*
325 Return t if DEVICE is able to play sound.  Defaults to selected device.
326 */
327        (device))
328 {
329 #ifdef HAVE_NAS_SOUND
330   if (DEVICE_CONNECTED_TO_NAS_P (decode_device (device)))
331     return Qt;
332 #endif
333 #ifdef HAVE_NATIVE_SOUND
334   if (DEVICE_ON_CONSOLE_P (decode_device (device)))
335     return Qt;
336 #endif
337   return Qnil;
338 }
339
340 DEFUN ("ding", Fding, 0, 3, 0, /*
341 Beep, or flash the frame.
342 Also, unless an argument is given,
343 terminate any keyboard macro currently executing.
344 When called from lisp, the second argument is what sound to make, and
345 the third argument is the device to make it in (defaults to the selected
346 device).
347 */
348        (arg, sound, device))
349 {
350   struct device *d = decode_device (device);
351
352   XSETDEVICE (device, d);
353
354   /* #### This is utterly disgusting, and is probably a remnant from
355      legacy code that used `ding'+`message' to signal error instead
356      calling `error'.  As a result, there is no way to beep from Lisp
357      directly, without also invoking this aspect.  Maybe we should
358      define a `ring-bell' function that simply beeps on the console,
359      which `ding' should invoke?  --hniksic */
360   if (NILP (arg) && !NILP (Vexecuting_macro))
361     /* Stop executing a keyboard macro. */
362     error ("Keyboard macro terminated by a command ringing the bell");
363   else if (visible_bell && DEVMETH (d, flash, (d)))
364     ;
365   else
366     Fplay_sound (sound, Qnil, device);
367
368   return Qnil;
369 }
370
371 DEFUN ("wait-for-sounds", Fwait_for_sounds, 0, 1, 0, /*
372 Wait for all sounds to finish playing on DEVICE.
373 */
374        (device))
375
376 {
377 #ifdef HAVE_NAS_SOUND
378   struct device *d = decode_device (device);
379   if (DEVICE_CONNECTED_TO_NAS_P (d))
380     {
381       /* #### somebody fix this to be device-dependent. */
382       nas_wait_for_sounds ();
383     }
384 #endif
385   return Qnil;
386 }
387
388 DEFUN ("connected-to-nas-p", Fconnected_to_nas_p, 0, 1, 0, /*
389 Return t if connected to NAS server for sounds on DEVICE.
390 */
391        (device))
392 {
393 #ifdef HAVE_NAS_SOUND
394   return DEVICE_CONNECTED_TO_NAS_P (decode_device (device)) ? Qt : Qnil;
395 #else
396   return Qnil;
397 #endif
398 }
399 #ifdef HAVE_NAS_SOUND
400
401 static void
402 init_nas_sound (struct device *d)
403 {
404   char *error;
405
406 #ifdef HAVE_X_WINDOWS
407   if (DEVICE_X_P (d))
408     {
409       error = nas_init_play (DEVICE_X_DISPLAY (d));
410       DEVICE_CONNECTED_TO_NAS_P (d) = !error;
411       /* Print out the message? */
412     }
413 #endif /* HAVE_X_WINDOWS */
414 }
415
416 #endif /* HAVE_NAS_SOUND */
417
418 #ifdef HAVE_NATIVE_SOUND
419
420 static void
421 init_native_sound (struct device *d)
422 {
423   if (DEVICE_TTY_P (d) || DEVICE_STREAM_P (d) || DEVICE_MSWINDOWS_P(d))
424     DEVICE_ON_CONSOLE_P (d) = 1;
425 #ifdef HAVE_X_WINDOWS
426   else
427     {
428       /* When running on a machine with native sound support, we cannot use
429          digitized sounds as beeps unless emacs is running on the same machine
430          that $DISPLAY points to, and $DISPLAY points to frame 0 of that
431          machine.
432          */
433
434       Display *display = DEVICE_X_DISPLAY (d);
435       char *dpy = DisplayString (display);
436       char *tail = (char *) strchr (dpy, ':');
437       if (! tail ||
438           strncmp (tail, ":0", 2))
439         DEVICE_ON_CONSOLE_P (d) = 0;
440       else
441         {
442           char dpyname[255], localname[255];
443
444           /* some systems can't handle SIGIO or SIGALARM in gethostbyname. */
445           stop_interrupts ();
446           strncpy (dpyname, dpy, tail-dpy);
447           dpyname [tail-dpy] = 0;
448           if (!*dpyname ||
449               !strcmp (dpyname, "unix") ||
450               !strcmp (dpyname, "localhost"))
451             DEVICE_ON_CONSOLE_P (d) = 1;
452           else if (gethostname (localname, sizeof (localname)))
453             DEVICE_ON_CONSOLE_P (d) = 0;        /* can't find hostname? */
454           else
455             {
456               /* We have to call gethostbyname() on the result of gethostname()
457                  because the two aren't guaranteed to be the same name for the
458                  same host: on some losing systems, one is a FQDN and the other
459                  is not.  Here in the wide wonderful world of Unix it's rocket
460                  science to obtain the local hostname in a portable fashion.
461
462                  And don't forget, gethostbyname() reuses the structure it
463                  returns, so we have to copy the fucker before calling it
464                  again.
465
466                  Thank you master, may I have another.
467                  */
468               struct hostent *h = gethostbyname (dpyname);
469               if (!h)
470                 DEVICE_ON_CONSOLE_P (d) = 0;
471               else
472                 {
473                   char hn [255];
474                   struct hostent *l;
475                   strcpy (hn, h->h_name);
476                   l = gethostbyname (localname);
477                   DEVICE_ON_CONSOLE_P (d) = (l && !(strcmp (l->h_name, hn)));
478                 }
479             }
480           start_interrupts ();
481         }
482     }
483 #endif /* HAVE_X_WINDOWS */
484 }
485
486 #endif /* HAVE_NATIVE_SOUND */
487
488 void
489 init_device_sound (struct device *d)
490 {
491 #ifdef HAVE_NAS_SOUND
492   init_nas_sound (d);
493 #endif
494
495 #ifdef HAVE_NATIVE_SOUND
496   init_native_sound (d);
497 #endif
498 }
499
500 void
501 syms_of_sound (void)
502 {
503   defkeyword (&Q_volume,   ":volume");
504   defkeyword (&Q_pitch,    ":pitch");
505   defkeyword (&Q_duration, ":duration");
506   defkeyword (&Q_sound,    ":sound");
507
508 #ifdef HAVE_NAS_SOUND
509   defsymbol (&Qnas, "nas");
510 #endif
511
512   DEFSUBR (Fplay_sound_file);
513   DEFSUBR (Fplay_sound);
514   DEFSUBR (Fding);
515   DEFSUBR (Fwait_for_sounds);
516   DEFSUBR (Fconnected_to_nas_p);
517   DEFSUBR (Fdevice_sound_enabled_p);
518 }
519
520
521 void
522 vars_of_sound (void)
523 {
524 #ifdef HAVE_NATIVE_SOUND
525   Fprovide (intern ("native-sound"));
526 #endif
527 #ifdef HAVE_NAS_SOUND
528   Fprovide (intern ("nas-sound"));
529 #endif
530
531   DEFVAR_INT ("bell-volume", &bell_volume /*
532 *How loud to be, from 0 to 100.
533 */ );
534   bell_volume = 50;
535
536   DEFVAR_LISP ("sound-alist", &Vsound_alist /*
537 An alist associating names with sounds.
538 When `beep' or `ding' is called with one of the name symbols, the associated
539 sound will be generated instead of the standard beep.
540
541 Each element of `sound-alist' is a list describing a sound.
542 The first element of the list is the name of the sound being defined.
543 Subsequent elements of the list are alternating keyword/value pairs:
544
545    Keyword:     Value:
546    -------      -----
547    sound        A string of raw sound data, or the name of another sound to
548                 play.   The symbol `t' here means use the default X beep.
549    volume       An integer from 0-100, defaulting to `bell-volume'
550    pitch        If using the default X beep, the pitch (Hz) to generate.
551    duration     If using the default X beep, the duration (milliseconds).
552
553 For compatibility, elements of `sound-alist' may also be:
554
555    ( sound-name . <sound> )
556    ( sound-name <volume> <sound> )
557
558 You should probably add things to this list by calling the function
559 load-sound-file.
560
561 Caveats:
562  - You can only play audio data if running on the console screen of a
563    Sun SparcStation, SGI, or HP9000s700.
564
565  - The pitch, duration, and volume options are available everywhere, but
566    many X servers ignore the `pitch' option.
567
568 The following beep-types are used by emacs itself:
569
570     auto-save-error     when an auto-save does not succeed
571     command-error       when the emacs command loop catches an error
572     undefined-key       when you type a key that is undefined
573     undefined-click     when you use an undefined mouse-click combination
574     no-completion       during completing-read
575     y-or-n-p            when you type something other than 'y' or 'n'
576     yes-or-no-p         when you type something other than 'yes' or 'no'
577     default             used when nothing else is appropriate.
578
579 Other lisp packages may use other beep types, but these are the ones that
580 the C kernel of Emacs uses.
581 */ );
582   Vsound_alist = Qnil;
583
584   DEFVAR_LISP ("synchronous-sounds", &Vsynchronous_sounds /*
585 Play sounds synchronously, if non-nil.
586 Only applies if NAS is used and supports asynchronous playing
587 of sounds.  Otherwise, sounds are always played synchronously.
588 */ );
589   Vsynchronous_sounds = Qnil;
590
591   DEFVAR_LISP ("native-sound-only-on-console", &Vnative_sound_only_on_console /*
592 Non-nil value means play sounds only if XEmacs is running
593 on the system console.
594 Nil means always always play sounds, even if running on a non-console tty
595 or a secondary X display.
596
597 This variable only applies to native sound support.
598 */ );
599   Vnative_sound_only_on_console = Qt;
600
601 #if defined (HAVE_NATIVE_SOUND) && defined (hp9000s800)
602   {
603     void vars_of_hpplay (void);
604     vars_of_hpplay ();
605   }
606 #endif
607 }