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