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