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