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