git.chise.org Git - chise/xemacs-chise.git.1/blob - 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 #ifdef HAVE_ESD_SOUND
  49 extern int esd_play_sound_file (char *file, int vol);
  50 extern int esd_play_sound_data (unsigned char *data, size_t length, int vol);
  51 # define DEVICE_CONNECTED_TO_ESD_P(x) 1 /* FIXME: better check */
  52 #endif
  53
  54 int bell_volume;
  55 int bell_inhibit_time;
  56 Lisp_Object Vsound_alist;
  57 Lisp_Object Vsynchronous_sounds;
  58 Lisp_Object Vnative_sound_only_on_console;
  59 Lisp_Object Q_volume, Q_pitch, Q_duration, Q_sound;
  60
  61 /* These are defined in the appropriate file (sunplay.c, sgiplay.c,
  62    or hpplay.c). */
  63
  64 extern void play_sound_file (char *name, int volume);
  65 extern void play_sound_data (unsigned char *data, int length, int volume);
  66
  67 #ifdef HAVE_NAS_SOUND
  68 extern int nas_play_sound_file (char *name, int volume);
  69 extern int nas_play_sound_data (unsigned char *data, int length, int volume);
  70 extern int nas_wait_for_sounds (void);
  71 extern char *nas_init_play (Display *);
  72
  73 Lisp_Object Qnas;
  74 #endif
  75
  76 DEFUN ("play-sound-file", Fplay_sound_file, 1, 3, "fSound file name: ", /*
  77 Play the named sound file on DEVICE's speaker at the specified volume
  78 \(0-100, default specified by the `bell-volume' variable).
  79 On Unix machines the sound file must be in the Sun/NeXT U-LAW format
  80 except under Linux where WAV files are also supported.  On Microsoft
  81 Windows the sound file must be in WAV format.
  82   DEVICE defaults to the selected device.
  83 */
  84      (file, volume, device))
  85 {
  86   /* This function can call lisp */
  87   int vol;
  88 #if defined (HAVE_NATIVE_SOUND) || defined (HAVE_NAS_SOUND) \
  89        || defined (HAVE_ESD_SOUND)
  90   struct device *d = decode_device (device);
  91 #endif
  92   struct gcpro gcpro1;
  93
  94   CHECK_STRING (file);
  95   if (NILP (volume))
  96     vol = bell_volume;
  97   else
  98     {
  99       CHECK_INT (volume);
 100       vol = XINT (volume);
 101     }
 102
 103   GCPRO1 (file);
 104   while (1)
 105     {
 106       file = Fexpand_file_name (file, Qnil);
 107       if (!NILP(Ffile_readable_p (file)))
 108         break;
 109       else
 110         {
 111           /* #### This is crockish.  It might be a better idea to try
 112              to open the file, and use report_file_error() if it
 113              fails.  --hniksic */
 114           if (NILP (Ffile_exists_p (file)))
 115             file =
 116               signal_simple_continuable_error ("File does not exist", file);
 117           else
 118             file =
 119               signal_simple_continuable_error ("File is unreadable", file);
 120         }
 121     }
 122   UNGCPRO;
 123
 124 #ifdef HAVE_NAS_SOUND
 125   if (DEVICE_CONNECTED_TO_NAS_P (d))
 126     {
 127       char *fileext;
 128
 129       GET_C_STRING_FILENAME_DATA_ALLOCA (file, fileext);
 130       /* #### NAS code should allow specification of a device. */
 131       if (nas_play_sound_file (fileext, vol))
 132         return Qnil;
 133     }
 134 #endif /* HAVE_NAS_SOUND */
 135
 136 #ifdef HAVE_ESD_SOUND
 137   if (DEVICE_CONNECTED_TO_ESD_P (d))
 138     {
 139       char *fileext;
 140
 141       GET_C_STRING_FILENAME_DATA_ALLOCA (file, fileext);
 142       if (esd_play_sound_file (fileext, vol))
 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       GET_C_STRING_FILENAME_DATA_ALLOCA (file, fileext);
 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       GET_STRING_BINARY_DATA_ALLOCA (sound, soundext, soundextlen);
 318       if (nas_play_sound_data ((unsigned char*)soundext, soundextlen, vol))
 319         return Qnil;
 320     }
 321 #endif /* HAVE_NAS_SOUND */
 322
 323 #ifdef HAVE_ESD_SOUND
 324   if (DEVICE_CONNECTED_TO_ESD_P (d) && STRINGP (sound))
 325     {
 326       Extbyte *soundext;
 327       Extcount soundextlen;
 328
 329       GET_STRING_BINARY_DATA_ALLOCA (sound, soundext, soundextlen);
 330       if (esd_play_sound_data (soundext, soundextlen, vol))
 331        return Qnil;
 332     }
 333 #endif /* HAVE_ESD_SOUND */
 334
 335 #ifdef HAVE_NATIVE_SOUND
 336   if ((NILP (Vnative_sound_only_on_console) || DEVICE_ON_CONSOLE_P (d))
 337       && STRINGP (sound))
 338     {
 339       CONST Extbyte *soundext;
 340       Extcount soundextlen;
 341
 342       GET_STRING_BINARY_DATA_ALLOCA (sound, soundext, soundextlen);
 343       /* The sound code doesn't like getting SIGIO interrupts. Unix sucks! */
 344       stop_interrupts ();
 345       play_sound_data ((unsigned char*)soundext, soundextlen, vol);
 346       start_interrupts ();
 347       QUIT;
 348       return Qnil;
 349     }
 350 #endif  /* HAVE_NATIVE_SOUND */
 351
 352   DEVMETH (d, ring_bell, (d, vol, pit, dur));
 353   return Qnil;
 354 }
 355
 356 DEFUN ("device-sound-enabled-p", Fdevice_sound_enabled_p, 0, 1, 0, /*
 357 Return t if DEVICE is able to play sound.  Defaults to selected device.
 358 */
 359        (device))
 360 {
 361 #ifdef HAVE_NAS_SOUND
 362   if (DEVICE_CONNECTED_TO_NAS_P (decode_device (device)))
 363     return Qt;
 364 #endif
 365 #ifdef HAVE_NATIVE_SOUND
 366   if (DEVICE_ON_CONSOLE_P (decode_device (device)))
 367     return Qt;
 368 #endif
 369   return Qnil;
 370 }
 371
 372 DEFUN ("ding", Fding, 0, 3, 0, /*
 373 Beep, or flash the frame.
 374 Also, unless an argument is given,
 375 terminate any keyboard macro currently executing.
 376 When called from lisp, the second argument is what sound to make, and
 377 the third argument is the device to make it in (defaults to the selected
 378 device).
 379 */
 380        (arg, sound, device))
 381 {
 382   static time_t last_bell_time;
 383   static struct device *last_bell_device;
 384   time_t now;
 385   struct device *d = decode_device (device);
 386
 387   XSETDEVICE (device, d);
 388   now = time (0);
 389
 390   if (NILP (arg) && !NILP (Vexecuting_macro))
 391     /* Stop executing a keyboard macro. */
 392     error ("Keyboard macro terminated by a command ringing the bell");
 393
 394   if (d == last_bell_device && now-last_bell_time < bell_inhibit_time)
 395     return Qnil;
 396   else if (visible_bell && DEVMETH (d, flash, (d)))
 397     ;
 398   else
 399     Fplay_sound (sound, Qnil, device);
 400
 401   last_bell_time = now;
 402   last_bell_device = d;
 403   return Qnil;
 404 }
 405
 406 DEFUN ("wait-for-sounds", Fwait_for_sounds, 0, 1, 0, /*
 407 Wait for all sounds to finish playing on DEVICE.
 408 */
 409        (device))
 410
 411 {
 412 #ifdef HAVE_NAS_SOUND
 413   struct device *d = decode_device (device);
 414   if (DEVICE_CONNECTED_TO_NAS_P (d))
 415     {
 416       /* #### somebody fix this to be device-dependent. */
 417       nas_wait_for_sounds ();
 418     }
 419 #endif
 420   return Qnil;
 421 }
 422
 423 DEFUN ("connected-to-nas-p", Fconnected_to_nas_p, 0, 1, 0, /*
 424 Return t if connected to NAS server for sounds on DEVICE.
 425 */
 426        (device))
 427 {
 428 #ifdef HAVE_NAS_SOUND
 429   return DEVICE_CONNECTED_TO_NAS_P (decode_device (device)) ? Qt : Qnil;
 430 #else
 431   return Qnil;
 432 #endif
 433 }
 434 #ifdef HAVE_NAS_SOUND
 435
 436 static void
 437 init_nas_sound (struct device *d)
 438 {
 439   char *error;
 440
 441 #ifdef HAVE_X_WINDOWS
 442   if (DEVICE_X_P (d))
 443     {
 444       error = nas_init_play (DEVICE_X_DISPLAY (d));
 445       DEVICE_CONNECTED_TO_NAS_P (d) = !error;
 446       /* Print out the message? */
 447     }
 448 #endif /* HAVE_X_WINDOWS */
 449 }
 450
 451 #endif /* HAVE_NAS_SOUND */
 452
 453 #ifdef HAVE_NATIVE_SOUND
 454
 455 static void
 456 init_native_sound (struct device *d)
 457 {
 458   if (DEVICE_TTY_P (d) || DEVICE_STREAM_P (d) || DEVICE_MSWINDOWS_P(d))
 459     DEVICE_ON_CONSOLE_P (d) = 1;
 460 #ifdef HAVE_X_WINDOWS
 461   else
 462     {
 463       /* When running on a machine with native sound support, we cannot use
 464          digitized sounds as beeps unless emacs is running on the same machine
 465          that $DISPLAY points to, and $DISPLAY points to frame 0 of that
 466          machine.
 467          */
 468
 469       Display *display = DEVICE_X_DISPLAY (d);
 470       char *dpy = DisplayString (display);
 471       char *tail = (char *) strchr (dpy, ':');
 472       if (! tail ||
 473           strncmp (tail, ":0", 2))
 474         DEVICE_ON_CONSOLE_P (d) = 0;
 475       else
 476         {
 477           char dpyname[255], localname[255];
 478
 479           /* some systems can't handle SIGIO or SIGALARM in gethostbyname. */
 480           stop_interrupts ();
 481           strncpy (dpyname, dpy, tail-dpy);
 482           dpyname [tail-dpy] = 0;
 483           if (!*dpyname ||
 484               !strcmp (dpyname, "unix") ||
 485               !strcmp (dpyname, "localhost"))
 486             DEVICE_ON_CONSOLE_P (d) = 1;
 487           else if (gethostname (localname, sizeof (localname)))
 488             DEVICE_ON_CONSOLE_P (d) = 0;        /* can't find hostname? */
 489           else
 490             {
 491               /* We have to call gethostbyname() on the result of gethostname()
 492                  because the two aren't guaranteed to be the same name for the
 493                  same host: on some losing systems, one is a FQDN and the other
 494                  is not.  Here in the wide wonderful world of Unix it's rocket
 495                  science to obtain the local hostname in a portable fashion.
 496
 497                  And don't forget, gethostbyname() reuses the structure it
 498                  returns, so we have to copy the fucker before calling it
 499                  again.
 500
 501                  Thank you master, may I have another.
 502                  */
 503               struct hostent *h = gethostbyname (dpyname);
 504               if (!h)
 505                 DEVICE_ON_CONSOLE_P (d) = 0;
 506               else
 507                 {
 508                   char hn [255];
 509                   struct hostent *l;
 510                   strcpy (hn, h->h_name);
 511                   l = gethostbyname (localname);
 512                   DEVICE_ON_CONSOLE_P (d) = (l && !(strcmp (l->h_name, hn)));
 513                 }
 514             }
 515           start_interrupts ();
 516         }
 517     }
 518 #endif /* HAVE_X_WINDOWS */
 519 }
 520
 521 #endif /* HAVE_NATIVE_SOUND */
 522
 523 void
 524 init_device_sound (struct device *d)
 525 {
 526 #ifdef HAVE_NAS_SOUND
 527   init_nas_sound (d);
 528 #endif
 529
 530 #ifdef HAVE_NATIVE_SOUND
 531   init_native_sound (d);
 532 #endif
 533 }
 534
 535 void
 536 syms_of_sound (void)
 537 {
 538   defkeyword (&Q_volume,   ":volume");
 539   defkeyword (&Q_pitch,    ":pitch");
 540   defkeyword (&Q_duration, ":duration");
 541   defkeyword (&Q_sound,    ":sound");
 542
 543 #ifdef HAVE_NAS_SOUND
 544   defsymbol (&Qnas, "nas");
 545 #endif
 546
 547   DEFSUBR (Fplay_sound_file);
 548   DEFSUBR (Fplay_sound);
 549   DEFSUBR (Fding);
 550   DEFSUBR (Fwait_for_sounds);
 551   DEFSUBR (Fconnected_to_nas_p);
 552   DEFSUBR (Fdevice_sound_enabled_p);
 553 }
 554
 555
 556 void
 557 vars_of_sound (void)
 558 {
 559 #ifdef HAVE_NATIVE_SOUND
 560   Fprovide (intern ("native-sound"));
 561 #endif
 562 #ifdef HAVE_NAS_SOUND
 563   Fprovide (intern ("nas-sound"));
 564 #endif
 565
 566   DEFVAR_INT ("bell-volume", &bell_volume /*
 567 *How loud to be, from 0 to 100.
 568 */ );
 569   bell_volume = 50;
 570
 571   DEFVAR_INT ("bell-inhibit-time", &bell_inhibit_time /*
 572 *Don't ring the bell on the same device more than once within this many seconds.
 573 */ );
 574   bell_inhibit_time = 0;
 575
 576   DEFVAR_LISP ("sound-alist", &Vsound_alist /*
 577 An alist associating names with sounds.
 578 When `beep' or `ding' is called with one of the name symbols, the associated
 579 sound will be generated instead of the standard beep.
 580
 581 Each element of `sound-alist' is a list describing a sound.
 582 The first element of the list is the name of the sound being defined.
 583 Subsequent elements of the list are alternating keyword/value pairs:
 584
 585    Keyword:     Value:
 586    -------      -----
 587    sound        A string of raw sound data, or the name of another sound to
 588                 play.   The symbol `t' here means use the default X beep.
 589    volume       An integer from 0-100, defaulting to `bell-volume'
 590    pitch        If using the default X beep, the pitch (Hz) to generate.
 591    duration     If using the default X beep, the duration (milliseconds).
 592
 593 For compatibility, elements of `sound-alist' may also be:
 594
 595    ( sound-name . <sound> )
 596    ( sound-name <volume> <sound> )
 597
 598 You should probably add things to this list by calling the function
 599 load-sound-file.
 600
 601 Caveats:
 602  - XEmacs must be built with sound support for your system.  Not all
 603    systems support sound.
 604
 605  - The pitch, duration, and volume options are available everywhere, but
 606    many X servers ignore the `pitch' option.
 607
 608 The following beep-types are used by emacs itself:
 609
 610     auto-save-error     when an auto-save does not succeed
 611     command-error       when the emacs command loop catches an error
 612     undefined-key       when you type a key that is undefined
 613     undefined-click     when you use an undefined mouse-click combination
 614     no-completion       during completing-read
 615     y-or-n-p            when you type something other than 'y' or 'n'
 616     yes-or-no-p         when you type something other than 'yes' or 'no'
 617     default             used when nothing else is appropriate.
 618
 619 Other lisp packages may use other beep types, but these are the ones that
 620 the C kernel of Emacs uses.
 621 */ );
 622   Vsound_alist = Qnil;
 623
 624   DEFVAR_LISP ("synchronous-sounds", &Vsynchronous_sounds /*
 625 Play sounds synchronously, if non-nil.
 626 Only applies if NAS is used and supports asynchronous playing
 627 of sounds.  Otherwise, sounds are always played synchronously.
 628 */ );
 629   Vsynchronous_sounds = Qnil;
 630
 631   DEFVAR_LISP ("native-sound-only-on-console", &Vnative_sound_only_on_console /*
 632 Non-nil value means play sounds only if XEmacs is running
 633 on the system console.
 634 Nil means always always play sounds, even if running on a non-console tty
 635 or a secondary X display.
 636
 637 This variable only applies to native sound support.
 638 */ );
 639   Vnative_sound_only_on_console = Qt;
 640
 641 #if defined (HAVE_NATIVE_SOUND) && defined (hp9000s800)
 642   {
 643     void vars_of_hpplay (void);
 644     vars_of_hpplay ();
 645   }
 646 #endif
 647 }