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 "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   struct device *d = decode_device(device);
 330
 331 #ifdef HAVE_NAS_SOUND
 332   if (DEVICE_CONNECTED_TO_NAS_P (d))
 333     return Qt;
 334 #endif
 335 #ifdef HAVE_NATIVE_SOUND
 336   if (DEVICE_ON_CONSOLE_P (d))
 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   struct device *d = decode_device (device);
 353
 354   XSETDEVICE (device, d);
 355
 356   /* #### This is utterly disgusting, and is probably a remnant from
 357      legacy code that used `ding'+`message' to signal error instead
 358      calling `error'.  As a result, there is no way to beep from Lisp
 359      directly, without also invoking this aspect.  Maybe we should
 360      define a `ring-bell' function that simply beeps on the console,
 361      which `ding' should invoke?  --hniksic */
 362   if (NILP (arg) && !NILP (Vexecuting_macro))
 363     /* Stop executing a keyboard macro. */
 364     error ("Keyboard macro terminated by a command ringing the bell");
 365   else if (visible_bell && DEVMETH (d, flash, (d)))
 366     ;
 367   else
 368     Fplay_sound (sound, Qnil, device);
 369
 370   return Qnil;
 371 }
 372
 373 DEFUN ("wait-for-sounds", Fwait_for_sounds, 0, 1, 0, /*
 374 Wait for all sounds to finish playing on DEVICE.
 375 */
 376        (device))
 377
 378 {
 379 #ifdef HAVE_NAS_SOUND
 380   struct device *d = decode_device (device);
 381   if (DEVICE_CONNECTED_TO_NAS_P (d))
 382     {
 383       /* #### somebody fix this to be device-dependent. */
 384       nas_wait_for_sounds ();
 385     }
 386 #endif
 387   return Qnil;
 388 }
 389
 390 DEFUN ("connected-to-nas-p", Fconnected_to_nas_p, 0, 1, 0, /*
 391 Return t if connected to NAS server for sounds on DEVICE.
 392 */
 393        (device))
 394 {
 395 #ifdef HAVE_NAS_SOUND
 396   return DEVICE_CONNECTED_TO_NAS_P (decode_device (device)) ? Qt : Qnil;
 397 #else
 398   return Qnil;
 399 #endif
 400 }
 401 #ifdef HAVE_NAS_SOUND
 402
 403 static void
 404 init_nas_sound (struct device *d)
 405 {
 406   char *error;
 407
 408 #ifdef HAVE_X_WINDOWS
 409   if (DEVICE_X_P (d))
 410     {
 411       error = nas_init_play (DEVICE_X_DISPLAY (d));
 412       DEVICE_CONNECTED_TO_NAS_P (d) = !error;
 413       /* Print out the message? */
 414     }
 415 #endif /* HAVE_X_WINDOWS */
 416 }
 417
 418 #endif /* HAVE_NAS_SOUND */
 419
 420 #ifdef HAVE_NATIVE_SOUND
 421
 422 static void
 423 init_native_sound (struct device *d)
 424 {
 425   if (DEVICE_TTY_P (d) || DEVICE_STREAM_P (d) || DEVICE_MSWINDOWS_P(d))
 426     DEVICE_ON_CONSOLE_P (d) = 1;
 427 #ifdef HAVE_X_WINDOWS
 428   else
 429     {
 430       /* When running on a machine with native sound support, we cannot use
 431          digitized sounds as beeps unless emacs is running on the same machine
 432          that $DISPLAY points to, and $DISPLAY points to frame 0 of that
 433          machine.
 434          */
 435
 436       Display *display = DEVICE_X_DISPLAY (d);
 437       char *dpy = DisplayString (display);
 438       char *tail = (char *) strchr (dpy, ':');
 439       if (! tail ||
 440           strncmp (tail, ":0", 2))
 441         DEVICE_ON_CONSOLE_P (d) = 0;
 442       else
 443         {
 444           char dpyname[255], localname[255];
 445
 446           /* some systems can't handle SIGIO or SIGALARM in gethostbyname. */
 447           stop_interrupts ();
 448           strncpy (dpyname, dpy, tail-dpy);
 449           dpyname [tail-dpy] = 0;
 450           if (!*dpyname ||
 451               !strcmp (dpyname, "unix") ||
 452               !strcmp (dpyname, "localhost"))
 453             DEVICE_ON_CONSOLE_P (d) = 1;
 454           else if (gethostname (localname, sizeof (localname)))
 455             DEVICE_ON_CONSOLE_P (d) = 0;        /* can't find hostname? */
 456           else
 457             {
 458               /* We have to call gethostbyname() on the result of gethostname()
 459                  because the two aren't guaranteed to be the same name for the
 460                  same host: on some losing systems, one is a FQDN and the other
 461                  is not.  Here in the wide wonderful world of Unix it's rocket
 462                  science to obtain the local hostname in a portable fashion.
 463
 464                  And don't forget, gethostbyname() reuses the structure it
 465                  returns, so we have to copy the fucker before calling it
 466                  again.
 467
 468                  Thank you master, may I have another.
 469                  */
 470               struct hostent *h = gethostbyname (dpyname);
 471               if (!h)
 472                 DEVICE_ON_CONSOLE_P (d) = 0;
 473               else
 474                 {
 475                   char hn [255];
 476                   struct hostent *l;
 477                   strcpy (hn, h->h_name);
 478                   l = gethostbyname (localname);
 479                   DEVICE_ON_CONSOLE_P (d) = (l && !(strcmp (l->h_name, hn)));
 480                 }
 481             }
 482           start_interrupts ();
 483         }
 484     }
 485 #endif /* HAVE_X_WINDOWS */
 486 }
 487
 488 #endif /* HAVE_NATIVE_SOUND */
 489
 490 void
 491 init_device_sound (struct device *d)
 492 {
 493 #ifdef HAVE_NAS_SOUND
 494   init_nas_sound (d);
 495 #endif
 496
 497 #ifdef HAVE_NATIVE_SOUND
 498   init_native_sound (d);
 499 #endif
 500 }
 501
 502 void
 503 syms_of_sound (void)
 504 {
 505   defkeyword (&Q_volume,   ":volume");
 506   defkeyword (&Q_pitch,    ":pitch");
 507   defkeyword (&Q_duration, ":duration");
 508   defkeyword (&Q_sound,    ":sound");
 509
 510 #ifdef HAVE_NAS_SOUND
 511   defsymbol (&Qnas, "nas");
 512 #endif
 513
 514   DEFSUBR (Fplay_sound_file);
 515   DEFSUBR (Fplay_sound);
 516   DEFSUBR (Fding);
 517   DEFSUBR (Fwait_for_sounds);
 518   DEFSUBR (Fconnected_to_nas_p);
 519   DEFSUBR (Fdevice_sound_enabled_p);
 520 }
 521
 522
 523 void
 524 vars_of_sound (void)
 525 {
 526 #ifdef HAVE_NATIVE_SOUND
 527   Fprovide (intern ("native-sound"));
 528 #endif
 529 #ifdef HAVE_NAS_SOUND
 530   Fprovide (intern ("nas-sound"));
 531 #endif
 532
 533   DEFVAR_INT ("bell-volume", &bell_volume /*
 534 *How loud to be, from 0 to 100.
 535 */ );
 536   bell_volume = 50;
 537
 538   DEFVAR_LISP ("sound-alist", &Vsound_alist /*
 539 An alist associating names with sounds.
 540 When `beep' or `ding' is called with one of the name symbols, the associated
 541 sound will be generated instead of the standard beep.
 542
 543 Each element of `sound-alist' is a list describing a sound.
 544 The first element of the list is the name of the sound being defined.
 545 Subsequent elements of the list are alternating keyword/value pairs:
 546
 547    Keyword:     Value:
 548    -------      -----
 549    sound        A string of raw sound data, or the name of another sound to
 550                 play.   The symbol `t' here means use the default X beep.
 551    volume       An integer from 0-100, defaulting to `bell-volume'
 552    pitch        If using the default X beep, the pitch (Hz) to generate.
 553    duration     If using the default X beep, the duration (milliseconds).
 554
 555 For compatibility, elements of `sound-alist' may also be:
 556
 557    ( sound-name . <sound> )
 558    ( sound-name <volume> <sound> )
 559
 560 You should probably add things to this list by calling the function
 561 load-sound-file.
 562
 563 Caveats:
 564  - You can only play audio data if running on the console screen of a
 565    Sun SparcStation, SGI, or HP9000s700.
 566
 567  - The pitch, duration, and volume options are available everywhere, but
 568    many X servers ignore the `pitch' option.
 569
 570 The following beep-types are used by emacs itself:
 571
 572     auto-save-error     when an auto-save does not succeed
 573     command-error       when the emacs command loop catches an error
 574     undefined-key       when you type a key that is undefined
 575     undefined-click     when you use an undefined mouse-click combination
 576     no-completion       during completing-read
 577     y-or-n-p            when you type something other than 'y' or 'n'
 578     yes-or-no-p         when you type something other than 'yes' or 'no'
 579     default             used when nothing else is appropriate.
 580
 581 Other lisp packages may use other beep types, but these are the ones that
 582 the C kernel of Emacs uses.
 583 */ );
 584   Vsound_alist = Qnil;
 585
 586   DEFVAR_LISP ("synchronous-sounds", &Vsynchronous_sounds /*
 587 Play sounds synchronously, if non-nil.
 588 Only applies if NAS is used and supports asynchronous playing
 589 of sounds.  Otherwise, sounds are always played synchronously.
 590 */ );
 591   Vsynchronous_sounds = Qnil;
 592
 593   DEFVAR_LISP ("native-sound-only-on-console", &Vnative_sound_only_on_console /*
 594 Non-nil value means play sounds only if XEmacs is running
 595 on the system console.
 596 Nil means always always play sounds, even if running on a non-console tty
 597 or a secondary X display.
 598
 599 This variable only applies to native sound support.
 600 */ );
 601   Vnative_sound_only_on_console = Qt;
 602
 603 #if defined (HAVE_NATIVE_SOUND) && defined (hp9000s800)
 604   {
 605     void vars_of_hpplay (void);
 606     vars_of_hpplay ();
 607   }
 608 #endif
 609 }