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 #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 }