git.chise.org Git - chise/xemacs-chise.git.1/blob - src/tooltalk.c

   1 /* Tooltalk support for Emacs.
   2    Copyright (C) 1993, 1994 Sun Microsystems, Inc.
   3    Copyright (C) 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 /* Written by John Rose <john.rose@eng.sun.com>.
  25    Heavily modified and cleaned up by Ben Wing <ben@xemacs.org>. */
  26
  27 #include <config.h>
  28 #include "lisp.h"
  29
  30 #include <X11/Xlib.h>
  31
  32 #include "buffer.h"
  33 #include "elhash.h"
  34 #include "process.h"
  35 #include "tooltalk.h"
  36 #include "syssignal.h"
  37
  38 Lisp_Object Vtooltalk_fd;
  39
  40 #ifdef TT_DEBUG
  41 static FILE *tooltalk_log_file;
  42 #endif
  43
  44 static Lisp_Object
  45   Vtooltalk_message_handler_hook,
  46   Vtooltalk_pattern_handler_hook,
  47   Vtooltalk_unprocessed_message_hook;
  48
  49 static Lisp_Object
  50   Qtooltalk_message_handler_hook,
  51   Qtooltalk_pattern_handler_hook,
  52   Qtooltalk_unprocessed_message_hook;
  53
  54 static Lisp_Object
  55   Qreceive_tooltalk_message,
  56   Qtt_address,
  57   Qtt_args_count,
  58   Qtt_arg_bval,
  59   Qtt_arg_ival,
  60   Qtt_arg_mode,
  61   Qtt_arg_type,
  62   Qtt_arg_val,
  63   Qtt_class,
  64   Qtt_category,
  65   Qtt_disposition,
  66   Qtt_file,
  67   Qtt_gid,
  68   Qtt_handler,
  69   Qtt_handler_ptype,
  70   Qtt_object,
  71   Qtt_op,
  72   Qtt_opnum,
  73   Qtt_otype,
  74   Qtt_scope,
  75   Qtt_sender,
  76   Qtt_sender_ptype,
  77   Qtt_session,
  78   Qtt_state,
  79   Qtt_status,
  80   Qtt_status_string,
  81   Qtt_uid,
  82   Qtt_callback,
  83   Qtt_plist,
  84   Qtt_prop,
  85
  86   Qtt_reject,                /* return-tooltalk-message */
  87   Qtt_reply,
  88   Qtt_fail,
  89
  90   Q_TT_MODE_UNDEFINED,       /* enum Tt_mode */
  91   Q_TT_IN,
  92   Q_TT_OUT,
  93   Q_TT_INOUT,
  94   Q_TT_MODE_LAST,
  95
  96   Q_TT_SCOPE_NONE,            /* enum Tt_scope */
  97   Q_TT_SESSION,
  98   Q_TT_FILE,
  99   Q_TT_BOTH,
 100   Q_TT_FILE_IN_SESSION,
 101
 102   Q_TT_CLASS_UNDEFINED,       /* enum Tt_class */
 103   Q_TT_NOTICE,
 104   Q_TT_REQUEST,
 105   Q_TT_CLASS_LAST,
 106
 107   Q_TT_CATEGORY_UNDEFINED,    /* enum Tt_category */
 108   Q_TT_OBSERVE,
 109   Q_TT_HANDLE,
 110   Q_TT_CATEGORY_LAST,
 111
 112   Q_TT_PROCEDURE,             /* typedef enum Tt_address */
 113   Q_TT_OBJECT,
 114   Q_TT_HANDLER,
 115   Q_TT_OTYPE,
 116   Q_TT_ADDRESS_LAST,
 117
 118   Q_TT_CREATED,               /* enum Tt_state */
 119   Q_TT_SENT,
 120   Q_TT_HANDLED,
 121   Q_TT_FAILED,
 122   Q_TT_QUEUED,
 123   Q_TT_STARTED,
 124   Q_TT_REJECTED,
 125   Q_TT_STATE_LAST,
 126
 127   Q_TT_DISCARD,              /* enum Tt_disposition */
 128   Q_TT_QUEUE,
 129   Q_TT_START;
 130
 131 static Lisp_Object Tooltalk_Message_plist_str, Tooltalk_Pattern_plist_str;
 132
 133 Lisp_Object Qtooltalk_error;
 134
 135 /* Used to GCPRO tooltalk message and pattern objects while
 136    they're sitting inside of some active tooltalk message or pattern.
 137    There may not be any other pointers to these objects. */
 138 Lisp_Object Vtooltalk_message_gcpro, Vtooltalk_pattern_gcpro;
 139 \f
 140
 141 /*                                     */
 142 /* machinery for tooltalk-message type */
 143 /*                                     */
 144
 145 Lisp_Object Qtooltalk_messagep;
 146
 147 struct Lisp_Tooltalk_Message
 148 {
 149   struct lcrecord_header header;
 150   Lisp_Object plist_sym, callback;
 151   Tt_message m;
 152 };
 153
 154 static Lisp_Object
 155 mark_tooltalk_message (Lisp_Object obj)
 156 {
 157   mark_object (XTOOLTALK_MESSAGE (obj)->callback);
 158   return XTOOLTALK_MESSAGE (obj)->plist_sym;
 159 }
 160
 161 static void
 162 print_tooltalk_message (Lisp_Object obj, Lisp_Object printcharfun,
 163                         int escapeflag)
 164 {
 165   Lisp_Tooltalk_Message *p = XTOOLTALK_MESSAGE (obj);
 166
 167   char buf[200];
 168
 169   if (print_readably)
 170     error ("printing unreadable object #<tooltalk_message 0x%x>",
 171            p->header.uid);
 172
 173   sprintf (buf, "#<tooltalk_message id:0x%lx 0x%x>", (long) (p->m), p->header.uid);
 174   write_c_string (buf, printcharfun);
 175 }
 176
 177 DEFINE_LRECORD_IMPLEMENTATION ("tooltalk-message", tooltalk_message,
 178                                mark_tooltalk_message, print_tooltalk_message,
 179                                0, 0, 0, 0,
 180                                Lisp_Tooltalk_Message);
 181 \f
 182 static Lisp_Object
 183 make_tooltalk_message (Tt_message m)
 184 {
 185   Lisp_Object val;
 186   Lisp_Tooltalk_Message *msg =
 187     alloc_lcrecord_type (Lisp_Tooltalk_Message, &lrecord_tooltalk_message);
 188
 189   msg->m = m;
 190   msg->callback = Qnil;
 191   msg->plist_sym = Fmake_symbol (Tooltalk_Message_plist_str);
 192   XSETTOOLTALK_MESSAGE (val, msg);
 193   return val;
 194 }
 195
 196 Tt_message
 197 unbox_tooltalk_message (Lisp_Object msg)
 198 {
 199   CHECK_TOOLTALK_MESSAGE (msg);
 200   return XTOOLTALK_MESSAGE (msg)->m;
 201 }
 202
 203 DEFUN ("tooltalk-message-p", Ftooltalk_message_p, 1, 1, 0, /*
 204 Return non-nil if OBJECT is a tooltalk message.
 205 */
 206        (object))
 207 {
 208   return TOOLTALK_MESSAGEP (object) ? Qt : Qnil;
 209 }
 210
 211
 212 \f
 213
 214 /*                                     */
 215 /* machinery for tooltalk-pattern type */
 216 /*                                     */
 217
 218 Lisp_Object Qtooltalk_patternp;
 219
 220 struct Lisp_Tooltalk_Pattern
 221 {
 222   struct lcrecord_header header;
 223   Lisp_Object plist_sym, callback;
 224   Tt_pattern p;
 225 };
 226
 227 static Lisp_Object
 228 mark_tooltalk_pattern (Lisp_Object obj)
 229 {
 230   mark_object (XTOOLTALK_PATTERN (obj)->callback);
 231   return XTOOLTALK_PATTERN (obj)->plist_sym;
 232 }
 233
 234 static void
 235 print_tooltalk_pattern (Lisp_Object obj, Lisp_Object printcharfun,
 236                         int escapeflag)
 237 {
 238   Lisp_Tooltalk_Pattern *p = XTOOLTALK_PATTERN (obj);
 239
 240   char buf[200];
 241
 242   if (print_readably)
 243     error ("printing unreadable object #<tooltalk_pattern 0x%x>",
 244            p->header.uid);
 245
 246   sprintf (buf, "#<tooltalk_pattern id:0x%lx 0x%x>", (long) (p->p), p->header.uid);
 247   write_c_string (buf, printcharfun);
 248 }
 249
 250 DEFINE_LRECORD_IMPLEMENTATION ("tooltalk-pattern", tooltalk_pattern,
 251                                mark_tooltalk_pattern, print_tooltalk_pattern,
 252                                0, 0, 0, 0,
 253                                Lisp_Tooltalk_Pattern);
 254 \f
 255 static Lisp_Object
 256 make_tooltalk_pattern (Tt_pattern p)
 257 {
 258   Lisp_Tooltalk_Pattern *pat =
 259     alloc_lcrecord_type (Lisp_Tooltalk_Pattern, &lrecord_tooltalk_pattern);
 260   Lisp_Object val;
 261
 262   pat->p = p;
 263   pat->callback = Qnil;
 264   pat->plist_sym = Fmake_symbol (Tooltalk_Pattern_plist_str);
 265
 266   XSETTOOLTALK_PATTERN (val, pat);
 267   return val;
 268 }
 269
 270 static Tt_pattern
 271 unbox_tooltalk_pattern (Lisp_Object pattern)
 272 {
 273   CHECK_TOOLTALK_PATTERN (pattern);
 274   return XTOOLTALK_PATTERN (pattern)->p;
 275 }
 276
 277 DEFUN ("tooltalk-pattern-p", Ftooltalk_pattern_p, 1, 1, 0, /*
 278 Return non-nil if OBJECT is a tooltalk pattern.
 279 */
 280        (object))
 281 {
 282   return TOOLTALK_PATTERNP (object) ? Qt : Qnil;
 283 }
 284
 285
 286 \f
 287
 288 static int
 289 tooltalk_constant_value (Lisp_Object s)
 290 {
 291   if (INTP (s))
 292     return XINT (s);
 293   else if (SYMBOLP (s))
 294     return XINT (XSYMBOL (s)->value);
 295   else
 296     return 0;   /* should never occur */
 297 }
 298
 299 static void
 300 check_status (Tt_status st)
 301 {
 302   if (tt_is_err (st))
 303     signal_error (Qtooltalk_error,
 304                   Fcons (build_string (tt_status_message (st)), Qnil));
 305 }
 306
 307 DEFUN ("receive-tooltalk-message", Freceive_tooltalk_message, 0, 2, 0, /*
 308 Run tt_message_receive().
 309 This function is the process handler for the ToolTalk connection process.
 310 */
 311        (ignore1, ignore2))
 312 {
 313   /* This function can GC */
 314   Tt_message mess = tt_message_receive ();
 315   Lisp_Object message_ = make_tooltalk_message (mess);
 316   struct gcpro gcpro1;
 317
 318   GCPRO1 (message_);
 319   if (mess != NULL && !NILP (Vtooltalk_unprocessed_message_hook))
 320     va_run_hook_with_args (Qtooltalk_unprocessed_message_hook, 1, message_);
 321   UNGCPRO;
 322
 323   /* see comment in event-stream.c about this return value. */
 324   return Qzero;
 325 }
 326
 327 static Tt_callback_action
 328 tooltalk_message_callback (Tt_message m, Tt_pattern p)
 329 {
 330   /* This function can GC */
 331   Lisp_Object cb;
 332   Lisp_Object message_;
 333   Lisp_Object pattern;
 334   struct gcpro gcpro1, gcpro2;
 335
 336 #ifdef TT_DEBUG
 337   int i, j;
 338
 339   fprintf (tooltalk_log_file, "message_cb: %d\n", m);
 340   fprintf (tooltalk_log_file, "op: %s (", tt_message_op (m));
 341   for (j = tt_message_args_count (m), i = 0; i < j; i++) {
 342     fprintf (tooltalk_log_file, "%s \"%s\"", tt_message_arg_type (m, i),
 343             tt_message_arg_val (m, i));
 344     fprintf (tooltalk_log_file, "%s", i == j-1 ? ")" : ", ");
 345   }
 346   fprintf (tooltalk_log_file, "\n\n");
 347   fflush (tooltalk_log_file);
 348 #endif
 349
 350   VOID_TO_LISP (message_, tt_message_user (m, TOOLTALK_MESSAGE_KEY));
 351   pattern = make_tooltalk_pattern (p);
 352   cb = XTOOLTALK_MESSAGE (message_)->callback;
 353   GCPRO2 (message_, pattern);
 354   if (!NILP (Vtooltalk_message_handler_hook))
 355     va_run_hook_with_args (Qtooltalk_message_handler_hook, 2,
 356                            message_, pattern);
 357
 358   if ((SYMBOLP (cb) && EQ (Qt, Ffboundp (cb))) ||
 359       (CONSP (cb) && EQ (Qlambda, Fcar (cb)) &&
 360        !NILP (Flistp (Fcar (Fcdr (cb))))))
 361     call2 (cb, message_, pattern);
 362   UNGCPRO;
 363
 364   tt_message_destroy (m);
 365   Fremhash (message_, Vtooltalk_message_gcpro);
 366
 367   return TT_CALLBACK_PROCESSED;
 368 }
 369
 370 static Tt_callback_action
 371 tooltalk_pattern_callback (Tt_message m, Tt_pattern p)
 372 {
 373   /* This function can GC */
 374   Lisp_Object cb;
 375   Lisp_Object message_;
 376   Lisp_Object pattern;
 377   struct gcpro gcpro1, gcpro2;
 378
 379 #ifdef TT_DEBUG
 380   int i, j;
 381
 382   fprintf (tooltalk_log_file, "pattern_cb: %d\n", m);
 383   fprintf (tooltalk_log_file, "op: %s (", tt_message_op (m));
 384   for (j = tt_message_args_count (m), i = 0; i < j; i++) {
 385     fprintf (tooltalk_log_file, "%s \"%s\"", tt_message_arg_type (m, i),
 386             tt_message_arg_val (m, i));
 387     fprintf (tooltalk_log_file, "%s", i == j-1 ? ")" : ", ");
 388   }
 389   fprintf (tooltalk_log_file, "\n\n");
 390   fflush (tooltalk_log_file);
 391 #endif
 392
 393   message_ = make_tooltalk_message (m);
 394   VOID_TO_LISP (pattern, tt_pattern_user (p, TOOLTALK_PATTERN_KEY));
 395   cb = XTOOLTALK_PATTERN (pattern)->callback;
 396   GCPRO2 (message_, pattern);
 397   if (!NILP (Vtooltalk_pattern_handler_hook))
 398     va_run_hook_with_args (Qtooltalk_pattern_handler_hook, 2,
 399                            message_, pattern);
 400
 401   if (SYMBOLP (cb) && EQ (Qt, Ffboundp (cb)))
 402     call2 (cb, message_, pattern);
 403   UNGCPRO;
 404
 405   tt_message_destroy (m);
 406   return TT_CALLBACK_PROCESSED;
 407 }
 408
 409 static Lisp_Object
 410 tt_mode_symbol (Tt_mode n)
 411 {
 412   switch (n)
 413     {
 414     case TT_MODE_UNDEFINED:     return Q_TT_MODE_UNDEFINED;
 415     case TT_IN:                 return Q_TT_IN;
 416     case TT_OUT:                return Q_TT_OUT;
 417     case TT_INOUT:              return Q_TT_INOUT;
 418     case TT_MODE_LAST:          return Q_TT_MODE_LAST;
 419     default:                    return Qnil;
 420     }
 421 }
 422
 423 static Lisp_Object
 424 tt_scope_symbol (Tt_scope n)
 425 {
 426   switch (n)
 427     {
 428     case TT_SCOPE_NONE:         return Q_TT_SCOPE_NONE;
 429     case TT_SESSION:            return Q_TT_SESSION;
 430     case TT_FILE:               return Q_TT_FILE;
 431     case TT_BOTH:               return Q_TT_BOTH;
 432     case TT_FILE_IN_SESSION:    return Q_TT_FILE_IN_SESSION;
 433     default:                    return Qnil;
 434     }
 435 }
 436
 437
 438 static Lisp_Object
 439 tt_class_symbol (Tt_class n)
 440 {
 441   switch (n)
 442     {
 443     case TT_CLASS_UNDEFINED:    return Q_TT_CLASS_UNDEFINED;
 444     case TT_NOTICE:             return Q_TT_NOTICE;
 445     case TT_REQUEST:            return Q_TT_REQUEST;
 446     case TT_CLASS_LAST:         return Q_TT_CLASS_LAST;
 447     default:                    return Qnil;
 448     }
 449 }
 450
 451 /*
 452  * This is not being used.  Is that a mistake or is this function
 453  * simply not necessary?
 454  */
 455 #if 0
 456 static Lisp_Object
 457 tt_category_symbol (Tt_category n)
 458 {
 459   switch (n)
 460     {
 461     case TT_CATEGORY_UNDEFINED: return Q_TT_CATEGORY_UNDEFINED;
 462     case TT_OBSERVE:            return Q_TT_OBSERVE;
 463     case TT_HANDLE:             return Q_TT_HANDLE;
 464     case TT_CATEGORY_LAST:      return Q_TT_CATEGORY_LAST;
 465     default:                    return Qnil;
 466     }
 467 }
 468 #endif /* 0 */
 469
 470 static Lisp_Object
 471 tt_address_symbol (Tt_address n)
 472 {
 473   switch (n)
 474     {
 475     case TT_PROCEDURE:          return Q_TT_PROCEDURE;
 476     case TT_OBJECT:             return Q_TT_OBJECT;
 477     case TT_HANDLER:            return Q_TT_HANDLER;
 478     case TT_OTYPE:              return Q_TT_OTYPE;
 479     case TT_ADDRESS_LAST:       return Q_TT_ADDRESS_LAST;
 480     default:                    return Qnil;
 481     }
 482 }
 483
 484 static Lisp_Object
 485 tt_state_symbol (Tt_state n)
 486 {
 487   switch (n)
 488     {
 489     case TT_CREATED:            return Q_TT_CREATED;
 490     case TT_SENT:               return Q_TT_SENT;
 491     case TT_HANDLED:            return Q_TT_HANDLED;
 492     case TT_FAILED:             return Q_TT_FAILED;
 493     case TT_QUEUED:             return Q_TT_QUEUED;
 494     case TT_STARTED:            return Q_TT_STARTED;
 495     case TT_REJECTED:           return Q_TT_REJECTED;
 496     case TT_STATE_LAST:         return Q_TT_STATE_LAST;
 497     default:                    return Qnil;
 498     }
 499 }
 500
 501 static Lisp_Object
 502 tt_build_string (char *s)
 503 {
 504   return build_string (s ? s : "");
 505 }
 506
 507 static Lisp_Object
 508 tt_opnum_string (int n)
 509 {
 510   char buf[32];
 511
 512   sprintf (buf, "%u", n);
 513   return build_string (buf);
 514 }
 515
 516 static Lisp_Object
 517 tt_message_arg_ival_string (Tt_message m, int n)
 518 {
 519   char buf[32];
 520   int value;
 521
 522   check_status (tt_message_arg_ival (m, n, &value));
 523   long_to_string (buf, value);
 524   return build_string (buf);
 525 }
 526
 527 static Lisp_Object
 528 tt_message_arg_bval_vector (Tt_message m, int n)
 529 {
 530   /* !!#### This function has not been Mule-ized */
 531   Bufbyte *value;
 532   int len = 0;
 533
 534   check_status (tt_message_arg_bval (m, n, &value, &len));
 535
 536   return make_string (value, len);
 537 }
 538
 539 DEFUN ("get-tooltalk-message-attribute", Fget_tooltalk_message_attribute,
 540        2, 3, 0, /*
 541 Return the indicated Tooltalk message attribute.  Attributes are
 542 identified by symbols with the same name (underscores and all) as the
 543 suffix of the Tooltalk tt_message_<attribute> function that extracts the value.
 544 String attribute values are copied, enumerated type values (except disposition)
 545 are converted to symbols - e.g. TT_HANDLER is 'TT_HANDLER, uid and gid are
 546 represented by fixnums (small integers), opnum is converted to a string,
 547 and disposition is converted to a fixnum.  We convert opnum (a C int) to a
 548 string, e.g. 123 => "123" because there's no guarantee that opnums will fit
 549 within the range of Lisp integers.
 550
 551 Use the 'plist attribute instead of the C API 'user attribute
 552 for user defined message data.  To retrieve the value of a message property
 553 specify the indicator for argn.  For example to get the value of a property
 554 called 'rflag, use
 555    (get-tooltalk-message-attribute message 'plist 'rflag)
 556
 557 To get the value of a message argument use one of the 'arg_val (strings),
 558 'arg_ival (integers), or 'arg_bval (strings with embedded nulls), attributes.
 559 For example to get the integer value of the third argument:
 560
 561    (get-tooltalk-message-attribute message 'arg_ival 2)
 562
 563 As you can see, argument numbers are zero based.  The type of each argument
 564 can be retrieved with the 'arg_type attribute; however, Tooltalk doesn't
 565 define any semantics for the string value of 'arg_type.  Conventionally
 566 "string" is used for strings and "int" for 32 bit integers.  Note that
 567 Emacs Lisp stores the lengths of strings explicitly (unlike C) so treating the
 568 value returned by 'arg_bval like a string is fine.
 569 */
 570        (message_, attribute, argn))
 571 {
 572   Tt_message m = unbox_tooltalk_message (message_);
 573   int n = 0;
 574
 575   CHECK_SYMBOL (attribute);
 576   if (EQ (attribute, (Qtt_arg_bval))  ||
 577       EQ (attribute, (Qtt_arg_ival))  ||
 578       EQ (attribute, (Qtt_arg_mode))  ||
 579       EQ (attribute, (Qtt_arg_type))  ||
 580       EQ (attribute, (Qtt_arg_val)))
 581     {
 582       CHECK_INT (argn);
 583       n = XINT (argn);
 584     }
 585
 586   if (!VALID_TOOLTALK_MESSAGEP (m))
 587     return Qnil;
 588
 589   else if (EQ (attribute, Qtt_arg_bval))
 590     return tt_message_arg_bval_vector (m, n);
 591
 592   else if (EQ (attribute, Qtt_arg_ival))
 593     return tt_message_arg_ival_string (m, n);
 594
 595   else if (EQ (attribute, Qtt_arg_mode))
 596     return tt_mode_symbol (tt_message_arg_mode (m, n));
 597
 598   else if (EQ (attribute, Qtt_arg_type))
 599     return tt_build_string (tt_message_arg_type (m, n));
 600
 601   else if (EQ (attribute, Qtt_arg_val))
 602     return tt_message_arg_bval_vector (m, n);
 603
 604   else if (EQ (attribute, Qtt_args_count))
 605     return make_int (tt_message_args_count (m));
 606
 607   else if (EQ (attribute, Qtt_address))
 608     return tt_address_symbol (tt_message_address (m));
 609
 610   else if (EQ (attribute, Qtt_class))
 611     return tt_class_symbol (tt_message_class (m));
 612
 613   else if (EQ (attribute, Qtt_disposition))
 614     return make_int (tt_message_disposition (m));
 615
 616   else if (EQ (attribute, Qtt_file))
 617     return tt_build_string (tt_message_file (m));
 618
 619   else if (EQ (attribute, Qtt_gid))
 620     return make_int (tt_message_gid (m));
 621
 622   else if (EQ (attribute, Qtt_handler))
 623     return tt_build_string (tt_message_handler (m));
 624
 625   else if (EQ (attribute, Qtt_handler_ptype))
 626     return tt_build_string (tt_message_handler_ptype (m));
 627
 628   else if (EQ (attribute, Qtt_object))
 629     return tt_build_string (tt_message_object (m));
 630
 631   else if (EQ (attribute, Qtt_op))
 632     return tt_build_string (tt_message_op (m));
 633
 634   else if (EQ (attribute, Qtt_opnum))
 635     return tt_opnum_string (tt_message_opnum (m));
 636
 637   else if (EQ (attribute, Qtt_otype))
 638     return tt_build_string (tt_message_otype (m));
 639
 640   else if (EQ (attribute, Qtt_scope))
 641     return tt_scope_symbol (tt_message_scope (m));
 642
 643   else if (EQ (attribute, Qtt_sender))
 644     return tt_build_string (tt_message_sender (m));
 645
 646   else if (EQ (attribute, Qtt_sender_ptype))
 647     return tt_build_string (tt_message_sender_ptype (m));
 648
 649   else if (EQ (attribute, Qtt_session))
 650     return tt_build_string (tt_message_session (m));
 651
 652   else if (EQ (attribute, Qtt_state))
 653     return tt_state_symbol (tt_message_state (m));
 654
 655   else if (EQ (attribute, Qtt_status))
 656     return make_int (tt_message_status (m));
 657
 658   else if (EQ (attribute, Qtt_status_string))
 659     return tt_build_string (tt_message_status_string (m));
 660
 661   else if (EQ (attribute, Qtt_uid))
 662     return make_int (tt_message_uid (m));
 663
 664   else if (EQ (attribute, Qtt_callback))
 665     return XTOOLTALK_MESSAGE (message_)->callback;
 666
 667   else if (EQ (attribute, Qtt_prop))
 668     return Fget (XTOOLTALK_MESSAGE (message_)->plist_sym, argn, Qnil);
 669
 670   else if (EQ (attribute, Qtt_plist))
 671     return Fcopy_sequence (Fsymbol_plist
 672                            (XTOOLTALK_MESSAGE (message_)->plist_sym));
 673
 674   else
 675     signal_simple_error ("Invalid value for `get-tooltalk-message-attribute'",
 676                          attribute);
 677
 678   return Qnil;
 679 }
 680
 681 DEFUN ("set-tooltalk-message-attribute", Fset_tooltalk_message_attribute,
 682        3, 4, 0, /*
 683 Initialize one Tooltalk message attribute.
 684
 685 Attribute names and values are the same as for
 686 `get-tooltalk-message-attribute'.  A property list is provided for user
 687 data (instead of the 'user message attribute); see
 688 `get-tooltalk-message-attribute'.
 689
 690 The value of callback should be the name of a function of one argument.
 691 It will be applied to the message and matching pattern each time the state of the
 692 message changes.  This is usually used to notice when the messages state has
 693 changed to TT_HANDLED (or TT_FAILED), so that reply argument values
 694 can be used.
 695
 696 If one of the argument attributes is specified, 'arg_val, 'arg_ival, or
 697 'arg_bval then argn must be the number of an already created argument.
 698 New arguments can be added to a message with add-tooltalk-message-arg.
 699 */
 700        (value, message_, attribute, argn))
 701 {
 702   Tt_message m = unbox_tooltalk_message (message_);
 703   int n = 0;
 704   Tt_status (*fun_str) (Tt_message, const char *) = 0;
 705
 706   CHECK_SYMBOL (attribute);
 707
 708   if (EQ (attribute, (Qtt_arg_bval))  ||
 709       EQ (attribute, (Qtt_arg_ival))  ||
 710       EQ (attribute, (Qtt_arg_val)))
 711     {
 712       CHECK_INT (argn);
 713       n = XINT (argn);
 714     }
 715
 716   if (!VALID_TOOLTALK_MESSAGEP (m))
 717     return Qnil;
 718
 719   if (EQ (attribute, Qtt_address))
 720     {
 721       CHECK_TOOLTALK_CONSTANT (value);
 722       tt_message_address_set (m, (Tt_address) tooltalk_constant_value (value));
 723     }
 724   else if (EQ (attribute, Qtt_class))
 725     {
 726       CHECK_TOOLTALK_CONSTANT (value);
 727       tt_message_class_set (m, (Tt_class) tooltalk_constant_value (value));
 728     }
 729   else if (EQ (attribute, Qtt_disposition))
 730     {
 731       CHECK_TOOLTALK_CONSTANT (value);
 732       tt_message_disposition_set (m, ((Tt_disposition)
 733                                       tooltalk_constant_value (value)));
 734     }
 735   else if (EQ (attribute, Qtt_scope))
 736     {
 737       CHECK_TOOLTALK_CONSTANT (value);
 738       tt_message_scope_set (m, (Tt_scope) tooltalk_constant_value (value));
 739     }
 740   else if (EQ (attribute, Qtt_file))
 741     fun_str = tt_message_file_set;
 742   else if (EQ (attribute, Qtt_handler_ptype))
 743     fun_str = tt_message_handler_ptype_set;
 744   else if (EQ (attribute, Qtt_handler))
 745     fun_str = tt_message_handler_set;
 746   else if (EQ (attribute, Qtt_object))
 747     fun_str = tt_message_object_set;
 748   else if (EQ (attribute, Qtt_op))
 749     fun_str = tt_message_op_set;
 750   else if (EQ (attribute, Qtt_otype))
 751     fun_str = tt_message_otype_set;
 752   else if (EQ (attribute, Qtt_sender_ptype))
 753     fun_str = tt_message_sender_ptype_set;
 754   else if (EQ (attribute, Qtt_session))
 755     fun_str = tt_message_session_set;
 756   else if (EQ (attribute, Qtt_status_string))
 757     fun_str = tt_message_status_string_set;
 758   else if (EQ (attribute, Qtt_arg_bval))
 759     {
 760       Extbyte *value_ext;
 761       Extcount value_ext_len;
 762       CHECK_STRING (value);
 763       TO_EXTERNAL_FORMAT (LISP_STRING, value,
 764                           ALLOCA, (value_ext, value_ext_len),
 765                           Qnative);
 766       tt_message_arg_bval_set (m, n, (unsigned char *) value_ext, value_ext_len);
 767     }
 768   else if (EQ (attribute, Qtt_arg_ival))
 769     {
 770       CHECK_INT (value);
 771       tt_message_arg_ival_set (m, n, XINT (value));
 772     }
 773   else if (EQ (attribute, Qtt_arg_val))
 774     {
 775       const char *value_ext;
 776       CHECK_STRING (value);
 777       LISP_STRING_TO_EXTERNAL (value, value_ext, Qnative);
 778       tt_message_arg_val_set (m, n, value_ext);
 779     }
 780   else if (EQ (attribute, Qtt_status))
 781     {
 782       CHECK_INT (value);
 783       tt_message_status_set (m, XINT (value));
 784     }
 785   else if (EQ (attribute, Qtt_callback))
 786     {
 787       CHECK_SYMBOL (value);
 788       XTOOLTALK_MESSAGE (message_)->callback = value;
 789     }
 790   else if (EQ (attribute, Qtt_prop))
 791     {
 792       return Fput (XTOOLTALK_MESSAGE (message_)->plist_sym, argn, value);
 793     }
 794   else
 795     signal_simple_error ("Invalid value for `set-tooltalk-message-attribute'",
 796                          attribute);
 797
 798   if (fun_str)
 799     {
 800       const char *value_ext;
 801       CHECK_STRING (value);
 802       LISP_STRING_TO_EXTERNAL (value, value_ext, Qnative);
 803       (*fun_str) (m, value_ext);
 804     }
 805
 806   return Qnil;
 807 }
 808
 809 DEFUN ("return-tooltalk-message", Freturn_tooltalk_message, 1, 2, 0, /*
 810 Send a reply to this message.  The second argument can be
 811 'reply, 'reject or 'fail; the default is 'reply.  Before sending
 812 a reply all message arguments whose mode is TT_INOUT or TT_OUT should
 813 have been filled in - see set-tooltalk-message-attribute.
 814 */
 815        (message_, mode))
 816 {
 817   Tt_message m = unbox_tooltalk_message (message_);
 818
 819   if (NILP (mode))
 820     mode = Qtt_reply;
 821   else
 822     CHECK_SYMBOL (mode);
 823
 824   if (!VALID_TOOLTALK_MESSAGEP (m))
 825     return Qnil;
 826   else if (EQ (mode, Qtt_reply))
 827     tt_message_reply (m);
 828   else if (EQ (mode, Qtt_reject))
 829     tt_message_reject (m);
 830   else if (EQ (mode, Qtt_fail))
 831     tt_message_fail (m);
 832
 833   return Qnil;
 834 }
 835
 836 DEFUN ("create-tooltalk-message", Fcreate_tooltalk_message, 0, 1, 0, /*
 837 Create a new tooltalk message.
 838 The messages session attribute is initialized to the default session.
 839 Other attributes can be initialized with `set-tooltalk-message-attribute'.
 840 `make-tooltalk-message' is the preferred to create and initialize a message.
 841
 842 Optional arg NO-CALLBACK says don't add a C-level callback at all.
 843 Normally don't do that; just don't specify the Lisp callback when
 844 calling `make-tooltalk-message'.
 845 */
 846        (no_callback))
 847 {
 848   Tt_message m = tt_message_create ();
 849   Lisp_Object message_ = make_tooltalk_message (m);
 850   if (NILP (no_callback))
 851     {
 852       tt_message_callback_add (m, tooltalk_message_callback);
 853     }
 854   tt_message_session_set (m, tt_default_session ());
 855   tt_message_user_set (m, TOOLTALK_MESSAGE_KEY, LISP_TO_VOID (message_));
 856   return message_;
 857 }
 858
 859 DEFUN ("destroy-tooltalk-message", Fdestroy_tooltalk_message, 1, 1, 0, /*
 860 Apply tt_message_destroy() to the message.
 861 It's not necessary to destroy messages after they've been processed by
 862 a message or pattern callback; the Lisp/Tooltalk callback machinery does
 863 this for you.
 864 */
 865        (message_))
 866 {
 867   Tt_message m = unbox_tooltalk_message (message_);
 868
 869   if (VALID_TOOLTALK_MESSAGEP (m))
 870     /* #### Should we call Fremhash() here?  It seems that
 871        a common paradigm is
 872
 873        (send-tooltalk-message)
 874        (destroy-tooltalk-message)
 875
 876        which would imply that destroying a sent ToolTalk message
 877        doesn't actually destroy it; when a response is sent back,
 878        the callback for the message will still be called.
 879
 880        But then maybe not: Maybe it really does destroy it,
 881        and the reason for that paradigm is that the author
 882        of `send-tooltalk-message' didn't really know what he
 883        was talking about when he said that it's a good idea
 884        to call `destroy-tooltalk-message' after sending it. */
 885     tt_message_destroy (m);
 886
 887   return Qnil;
 888 }
 889
 890
 891 DEFUN ("add-tooltalk-message-arg", Fadd_tooltalk_message_arg, 3, 4, 0, /*
 892 Append one new argument to the message.
 893 MODE must be one of TT_IN, TT_INOUT, or TT_OUT; VTYPE must be a string;
 894 and VALUE can be a string or an integer.   Tooltalk doesn't
 895 define any semantics for VTYPE, so only the participants in the
 896 protocol you're using need to agree what types mean (if anything).
 897 Conventionally "string" is used for strings and "int" for 32 bit integers.
 898 Arguments can initialized by providing a value or with
 899 `set-tooltalk-message-attribute'.  The latter is necessary if you
 900 want to initialize the argument with a string that can contain
 901 embedded nulls (use 'arg_bval).
 902 */
 903        (message_, mode, vtype, value))
 904 {
 905   Tt_message m = unbox_tooltalk_message (message_);
 906   Tt_mode n;
 907
 908   CHECK_STRING (vtype);
 909   CHECK_TOOLTALK_CONSTANT (mode);
 910
 911   n = (Tt_mode) tooltalk_constant_value (mode);
 912
 913   if (!VALID_TOOLTALK_MESSAGEP (m))
 914     return Qnil;
 915   {
 916     const char *vtype_ext;
 917
 918     LISP_STRING_TO_EXTERNAL (vtype, vtype_ext, Qnative);
 919     if (NILP (value))
 920       tt_message_arg_add (m, n, vtype_ext, NULL);
 921     else if (STRINGP (value))
 922       {
 923         const char *value_ext;
 924         LISP_STRING_TO_EXTERNAL (value, value_ext, Qnative);
 925         tt_message_arg_add (m, n, vtype_ext, value_ext);
 926       }
 927     else if (INTP (value))
 928       tt_message_iarg_add (m, n, vtype_ext, XINT (value));
 929   }
 930
 931   return Qnil;
 932 }
 933
 934 DEFUN ("send-tooltalk-message", Fsend_tooltalk_message, 1, 1, 0, /*
 935 Send the message on its way.
 936 Once the message has been sent it's almost always a good idea to get rid of
 937 it with `destroy-tooltalk-message'.
 938 */
 939        (message_))
 940 {
 941   Tt_message m = unbox_tooltalk_message (message_);
 942
 943   if (VALID_TOOLTALK_MESSAGEP (m))
 944     {
 945       tt_message_send (m);
 946       Fputhash (message_, Qnil, Vtooltalk_message_gcpro);
 947     }
 948
 949   return Qnil;
 950 }
 951
 952 DEFUN ("create-tooltalk-pattern", Fcreate_tooltalk_pattern, 0, 0, 0, /*
 953 Create a new Tooltalk pattern.
 954 Its session attribute is initialized to be the default session.
 955 */
 956        ())
 957 {
 958   Tt_pattern p = tt_pattern_create ();
 959   Lisp_Object pattern = make_tooltalk_pattern (p);
 960
 961   tt_pattern_callback_add (p, tooltalk_pattern_callback);
 962   tt_pattern_session_add (p, tt_default_session ());
 963   tt_pattern_user_set (p, TOOLTALK_PATTERN_KEY, LISP_TO_VOID (pattern));
 964
 965   return pattern;
 966 }
 967
 968
 969 DEFUN ("destroy-tooltalk-pattern", Fdestroy_tooltalk_pattern, 1, 1, 0, /*
 970 Apply tt_pattern_destroy() to the pattern.
 971 This effectively unregisters the pattern.
 972 */
 973        (pattern))
 974 {
 975   Tt_pattern p = unbox_tooltalk_pattern (pattern);
 976
 977   if (VALID_TOOLTALK_PATTERNP (p))
 978     {
 979       tt_pattern_destroy (p);
 980       Fremhash (pattern, Vtooltalk_pattern_gcpro);
 981     }
 982
 983   return Qnil;
 984 }
 985
 986
 987 DEFUN ("add-tooltalk-pattern-attribute", Fadd_tooltalk_pattern_attribute, 3, 3, 0, /*
 988 Add one value to the indicated pattern attribute.
 989 All Tooltalk pattern attributes are supported except 'user.  The names
 990 of attributes are the same as the Tooltalk accessors used to set them
 991 less the "tooltalk_pattern_" prefix and the "_add" ...
 992 */
 993        (value, pattern, attribute))
 994 {
 995   Tt_pattern p = unbox_tooltalk_pattern (pattern);
 996
 997   CHECK_SYMBOL (attribute);
 998
 999   if (!VALID_TOOLTALK_PATTERNP (p))
1000     return Qnil;
1001
1002   else if (EQ (attribute, Qtt_category))
1003     {
1004       CHECK_TOOLTALK_CONSTANT (value);
1005       tt_pattern_category_set (p, ((Tt_category)
1006                                    tooltalk_constant_value (value)));
1007     }
1008   else if (EQ (attribute, Qtt_address))
1009     {
1010       CHECK_TOOLTALK_CONSTANT (value);
1011       tt_pattern_address_add (p, ((Tt_address)
1012                                   tooltalk_constant_value (value)));
1013     }
1014   else if (EQ (attribute, Qtt_class))
1015     {
1016       CHECK_TOOLTALK_CONSTANT (value);
1017       tt_pattern_class_add (p, (Tt_class) tooltalk_constant_value (value));
1018     }
1019   else if (EQ (attribute, Qtt_disposition))
1020     {
1021       CHECK_TOOLTALK_CONSTANT (value);
1022       tt_pattern_disposition_add (p, ((Tt_disposition)
1023                                       tooltalk_constant_value (value)));
1024     }
1025   else if (EQ (attribute, Qtt_file))
1026     {
1027       const char *value_ext;
1028       CHECK_STRING (value);
1029       LISP_STRING_TO_EXTERNAL (value, value_ext, Qnative);
1030       tt_pattern_file_add (p, value_ext);
1031     }
1032   else if (EQ (attribute, Qtt_object))
1033     {
1034       const char *value_ext;
1035       CHECK_STRING (value);
1036       LISP_STRING_TO_EXTERNAL (value, value_ext, Qnative);
1037       tt_pattern_object_add (p, value_ext);
1038     }
1039   else if (EQ (attribute, Qtt_op))
1040     {
1041       const char *value_ext;
1042       CHECK_STRING (value);
1043       LISP_STRING_TO_EXTERNAL (value, value_ext, Qnative);
1044       tt_pattern_op_add (p, value_ext);
1045     }
1046   else if (EQ (attribute, Qtt_otype))
1047     {
1048       const char *value_ext;
1049       CHECK_STRING (value);
1050       LISP_STRING_TO_EXTERNAL (value, value_ext, Qnative);
1051       tt_pattern_otype_add (p, value_ext);
1052     }
1053   else if (EQ (attribute, Qtt_scope))
1054     {
1055       CHECK_TOOLTALK_CONSTANT (value);
1056       tt_pattern_scope_add (p, (Tt_scope) tooltalk_constant_value (value));
1057     }
1058   else if (EQ (attribute, Qtt_sender))
1059     {
1060       const char *value_ext;
1061       CHECK_STRING (value);
1062       LISP_STRING_TO_EXTERNAL (value, value_ext, Qnative);
1063       tt_pattern_sender_add (p, value_ext);
1064     }
1065   else if (EQ (attribute, Qtt_sender_ptype))
1066     {
1067       const char *value_ext;
1068       CHECK_STRING (value);
1069       LISP_STRING_TO_EXTERNAL (value, value_ext, Qnative);
1070       tt_pattern_sender_ptype_add (p, value_ext);
1071     }
1072   else if (EQ (attribute, Qtt_session))
1073     {
1074       const char *value_ext;
1075       CHECK_STRING (value);
1076       LISP_STRING_TO_EXTERNAL (value, value_ext, Qnative);
1077       tt_pattern_session_add (p, value_ext);
1078     }
1079   else if (EQ (attribute, Qtt_state))
1080     {
1081       CHECK_TOOLTALK_CONSTANT (value);
1082       tt_pattern_state_add (p, (Tt_state) tooltalk_constant_value (value));
1083     }
1084   else if (EQ (attribute, Qtt_callback))
1085     {
1086       CHECK_SYMBOL (value);
1087       XTOOLTALK_PATTERN (pattern)->callback = value;
1088     }
1089
1090   return Qnil;
1091 }
1092
1093
1094 DEFUN ("add-tooltalk-pattern-arg", Fadd_tooltalk_pattern_arg, 3, 4, 0, /*
1095 Add one fully specified argument to a tooltalk pattern.
1096 Mode must be one of TT_IN, TT_INOUT, or TT_OUT, type must be a string.
1097 Value can be an integer, string or nil.  If value is an integer then
1098 an integer argument (tt_pattern_iarg_add) added otherwise a string argument
1099 is added.  At present there's no way to add a binary data argument.
1100 */
1101      (pattern, mode, vtype, value))
1102 {
1103   Tt_pattern p = unbox_tooltalk_pattern (pattern);
1104   Tt_mode n;
1105
1106   CHECK_STRING (vtype);
1107   CHECK_TOOLTALK_CONSTANT (mode);
1108
1109   n = (Tt_mode) tooltalk_constant_value (mode);
1110
1111   if (!VALID_TOOLTALK_PATTERNP (p))
1112     return Qnil;
1113
1114   {
1115     const char *vtype_ext;
1116
1117     LISP_STRING_TO_EXTERNAL (vtype, vtype_ext, Qnative);
1118     if (NILP (value))
1119       tt_pattern_arg_add (p, n, vtype_ext, NULL);
1120     else if (STRINGP (value))
1121       {
1122         const char *value_ext;
1123         LISP_STRING_TO_EXTERNAL (value, value_ext, Qnative);
1124         tt_pattern_arg_add (p, n, vtype_ext, value_ext);
1125       }
1126     else if (INTP (value))
1127       tt_pattern_iarg_add (p, n, vtype_ext, XINT (value));
1128   }
1129
1130   return Qnil;
1131 }
1132
1133
1134 DEFUN ("register-tooltalk-pattern", Fregister_tooltalk_pattern, 1, 1, 0, /*
1135 Emacs will begin receiving messages that match this pattern.
1136 */
1137        (pattern))
1138 {
1139   Tt_pattern p = unbox_tooltalk_pattern (pattern);
1140
1141   if (VALID_TOOLTALK_PATTERNP (p) && tt_pattern_register (p) == TT_OK)
1142     {
1143       Fputhash (pattern, Qnil, Vtooltalk_pattern_gcpro);
1144       return Qt;
1145     }
1146   else
1147     return Qnil;
1148 }
1149
1150
1151 DEFUN ("unregister-tooltalk-pattern", Funregister_tooltalk_pattern, 1, 1, 0, /*
1152 Emacs will stop receiving messages that match this pattern.
1153 */
1154        (pattern))
1155 {
1156   Tt_pattern p = unbox_tooltalk_pattern (pattern);
1157
1158   if (VALID_TOOLTALK_PATTERNP (p))
1159     {
1160       tt_pattern_unregister (p);
1161       Fremhash (pattern, Vtooltalk_pattern_gcpro);
1162     }
1163
1164   return Qnil;
1165 }
1166
1167
1168 DEFUN ("tooltalk-pattern-prop-get", Ftooltalk_pattern_prop_get, 2, 2, 0, /*
1169 Return the value of PROPERTY in tooltalk pattern PATTERN.
1170 This is the last value set with `tooltalk-pattern-prop-set'.
1171 */
1172        (pattern, property))
1173 {
1174   CHECK_TOOLTALK_PATTERN (pattern);
1175   return Fget (XTOOLTALK_PATTERN (pattern)->plist_sym, property, Qnil);
1176 }
1177
1178
1179 DEFUN ("tooltalk-pattern-prop-set", Ftooltalk_pattern_prop_set, 3, 3, 0, /*
1180 Set the value of PROPERTY to VALUE in tooltalk pattern PATTERN.
1181 It can be retrieved with `tooltalk-pattern-prop-get'.
1182 */
1183        (pattern, property, value))
1184 {
1185   CHECK_TOOLTALK_PATTERN (pattern);
1186   return Fput (XTOOLTALK_PATTERN (pattern)->plist_sym, property, value);
1187 }
1188
1189
1190 DEFUN ("tooltalk-pattern-plist-get", Ftooltalk_pattern_plist_get, 1, 1, 0, /*
1191 Return the a list of all the properties currently set in PATTERN.
1192 */
1193        (pattern))
1194 {
1195   CHECK_TOOLTALK_PATTERN (pattern);
1196   return
1197     Fcopy_sequence (Fsymbol_plist (XTOOLTALK_PATTERN (pattern)->plist_sym));
1198 }
1199
1200 DEFUN ("tooltalk-default-procid", Ftooltalk_default_procid, 0, 0, 0, /*
1201 Return current default process identifier for your process.
1202 */
1203        ())
1204 {
1205   char *procid = tt_default_procid ();
1206   return procid ? build_string (procid) : Qnil;
1207 }
1208
1209 DEFUN ("tooltalk-default-session", Ftooltalk_default_session, 0, 0, 0, /*
1210 Return current default session identifier for the current default procid.
1211 */
1212        ())
1213 {
1214   char *session = tt_default_session ();
1215   return session ? build_string (session) : Qnil;
1216 }
1217
1218 static void
1219 init_tooltalk (void)
1220 {
1221   /* This function can GC */
1222   char *retval;
1223   Lisp_Object lp;
1224   Lisp_Object fil;
1225
1226
1227   /* tt_open() messes with our signal handler flags (at least when no
1228      ttsessions is running on the machine), therefore we save the
1229      actions and restore them after the call */
1230 #ifdef HAVE_SIGPROCMASK
1231   {
1232     struct sigaction ActSIGQUIT;
1233     struct sigaction ActSIGINT;
1234     struct sigaction ActSIGCHLD;
1235     sigaction (SIGQUIT, NULL, &ActSIGQUIT);
1236     sigaction (SIGINT, NULL, &ActSIGINT);
1237     sigaction (SIGCHLD, NULL, &ActSIGCHLD);
1238 #endif
1239   retval = tt_open ();
1240 #ifdef HAVE_SIGPROCMASK
1241     sigaction (SIGQUIT, &ActSIGQUIT, NULL);
1242     sigaction (SIGINT, &ActSIGINT, NULL);
1243     sigaction (SIGCHLD, &ActSIGCHLD, NULL);
1244   }
1245 #endif
1246
1247
1248   if (tt_ptr_error (retval) != TT_OK)
1249     return;
1250
1251   Vtooltalk_fd = make_int (tt_fd ());
1252
1253   tt_session_join (tt_default_session ());
1254
1255   lp = connect_to_file_descriptor (build_string ("tooltalk"), Qnil,
1256                                    Vtooltalk_fd, Vtooltalk_fd);
1257   if (!NILP (lp))
1258     {
1259       /* Don't ask the user for confirmation when exiting Emacs */
1260       Fprocess_kill_without_query (lp, Qnil);
1261       XSETSUBR (fil, &SFreceive_tooltalk_message);
1262       set_process_filter (lp, fil, 1);
1263     }
1264   else
1265     {
1266       tt_close ();
1267       Vtooltalk_fd = Qnil;
1268       return;
1269     }
1270
1271 #if defined (SOLARIS2)
1272   /* Apparently the tt_message_send_on_exit() function does not exist
1273      under SunOS 4.x or IRIX 5 or various other non-Solaris-2 systems.
1274      No big deal if we don't do the following under those systems. */
1275   {
1276     Tt_message exit_msg = tt_message_create ();
1277
1278     tt_message_op_set (exit_msg, "emacs-aborted");
1279     tt_message_scope_set (exit_msg, TT_SESSION);
1280     tt_message_class_set (exit_msg, TT_NOTICE);
1281     tt_message_send_on_exit (exit_msg);
1282     tt_message_destroy (exit_msg);
1283   }
1284 #endif
1285 }
1286
1287 DEFUN ("tooltalk-open-connection", Ftooltalk_open_connection, 0, 0, 0, /*
1288 Opens a connection to the ToolTalk server.
1289 Returns t if successful, nil otherwise.
1290 */
1291        ())
1292 {
1293   if (!NILP (Vtooltalk_fd))
1294     error ("Already connected to ToolTalk.");
1295   if (noninteractive)
1296     error ("Can't connect to ToolTalk in batch mode.");
1297   init_tooltalk ();
1298   return NILP (Vtooltalk_fd) ? Qnil : Qt;
1299 }
1300
1301
1302 void
1303 syms_of_tooltalk (void)
1304 {
1305   INIT_LRECORD_IMPLEMENTATION (tooltalk_message);
1306   INIT_LRECORD_IMPLEMENTATION (tooltalk_pattern);
1307
1308   defsymbol (&Qtooltalk_messagep, "tooltalk-message-p");
1309   DEFSUBR (Ftooltalk_message_p);
1310   defsymbol (&Qtooltalk_patternp, "tooltalk-pattern-p");
1311   DEFSUBR (Ftooltalk_pattern_p);
1312   defsymbol (&Qtooltalk_message_handler_hook, "tooltalk-message-handler-hook");
1313   defsymbol (&Qtooltalk_pattern_handler_hook, "tooltalk-pattern-handler-hook");
1314   defsymbol (&Qtooltalk_unprocessed_message_hook,
1315              "tooltalk-unprocessed-message-hook");
1316
1317   DEFSUBR (Freceive_tooltalk_message);
1318   DEFSUBR (Fcreate_tooltalk_message);
1319   DEFSUBR (Fdestroy_tooltalk_message);
1320   DEFSUBR (Fadd_tooltalk_message_arg);
1321   DEFSUBR (Fget_tooltalk_message_attribute);
1322   DEFSUBR (Fset_tooltalk_message_attribute);
1323   DEFSUBR (Fsend_tooltalk_message);
1324   DEFSUBR (Freturn_tooltalk_message);
1325   DEFSUBR (Fcreate_tooltalk_pattern);
1326   DEFSUBR (Fdestroy_tooltalk_pattern);
1327   DEFSUBR (Fadd_tooltalk_pattern_attribute);
1328   DEFSUBR (Fadd_tooltalk_pattern_arg);
1329   DEFSUBR (Fregister_tooltalk_pattern);
1330   DEFSUBR (Funregister_tooltalk_pattern);
1331   DEFSUBR (Ftooltalk_pattern_plist_get);
1332   DEFSUBR (Ftooltalk_pattern_prop_set);
1333   DEFSUBR (Ftooltalk_pattern_prop_get);
1334   DEFSUBR (Ftooltalk_default_procid);
1335   DEFSUBR (Ftooltalk_default_session);
1336   DEFSUBR (Ftooltalk_open_connection);
1337
1338   defsymbol (&Qreceive_tooltalk_message, "receive-tooltalk-message");
1339   defsymbol (&Qtt_address, "address");
1340   defsymbol (&Qtt_args_count, "args_count");
1341   defsymbol (&Qtt_arg_bval, "arg_bval");
1342   defsymbol (&Qtt_arg_ival, "arg_ival");
1343   defsymbol (&Qtt_arg_mode, "arg_mode");
1344   defsymbol (&Qtt_arg_type, "arg_type");
1345   defsymbol (&Qtt_arg_val, "arg_val");
1346   defsymbol (&Qtt_class, "class");
1347   defsymbol (&Qtt_category, "category");
1348   defsymbol (&Qtt_disposition, "disposition");
1349   defsymbol (&Qtt_file, "file");
1350   defsymbol (&Qtt_gid, "gid");
1351   defsymbol (&Qtt_handler, "handler");
1352   defsymbol (&Qtt_handler_ptype, "handler_ptype");
1353   defsymbol (&Qtt_object, "object");
1354   defsymbol (&Qtt_op, "op");
1355   defsymbol (&Qtt_opnum, "opnum");
1356   defsymbol (&Qtt_otype, "otype");
1357   defsymbol (&Qtt_scope, "scope");
1358   defsymbol (&Qtt_sender, "sender");
1359   defsymbol (&Qtt_sender_ptype, "sender_ptype");
1360   defsymbol (&Qtt_session, "session");
1361   defsymbol (&Qtt_state, "state");
1362   defsymbol (&Qtt_status, "status");
1363   defsymbol (&Qtt_status_string, "status_string");
1364   defsymbol (&Qtt_uid, "uid");
1365   defsymbol (&Qtt_callback, "callback");
1366   defsymbol (&Qtt_prop, "prop");
1367   defsymbol (&Qtt_plist, "plist");
1368   defsymbol (&Qtt_reject, "reject");
1369   defsymbol (&Qtt_reply, "reply");
1370   defsymbol (&Qtt_fail, "fail");
1371
1372   DEFERROR (Qtooltalk_error, "ToolTalk error", Qio_error);
1373 }
1374
1375 void
1376 vars_of_tooltalk (void)
1377 {
1378   Fprovide (intern ("tooltalk"));
1379
1380   DEFVAR_LISP ("tooltalk-fd", &Vtooltalk_fd /*
1381 File descriptor returned by tt_initialize; nil if not connected to ToolTalk.
1382 */ );
1383   Vtooltalk_fd = Qnil;
1384
1385   DEFVAR_LISP ("tooltalk-message-handler-hook",
1386               &Vtooltalk_message_handler_hook /*
1387 List of functions to be applied to each ToolTalk message reply received.
1388 This will always occur as a result of our sending a request message.
1389 Functions will be called with two arguments, the message and the
1390 corresponding pattern.  This hook will not be called if the request
1391 message was created without a C-level callback function (see
1392 `tooltalk-unprocessed-message-hook').
1393 */ );
1394   Vtooltalk_message_handler_hook = Qnil;
1395
1396   DEFVAR_LISP ("tooltalk-pattern-handler-hook",
1397               &Vtooltalk_pattern_handler_hook /*
1398 List of functions to be applied to each pattern-matching ToolTalk message.
1399 This is all messages except those handled by `tooltalk-message-handler-hook'.
1400 Functions will be called with two arguments, the message and the
1401 corresponding pattern.
1402 */ );
1403   Vtooltalk_pattern_handler_hook = Qnil;
1404
1405   DEFVAR_LISP ("tooltalk-unprocessed-message-hook",
1406               &Vtooltalk_unprocessed_message_hook /*
1407 List of functions to be applied to each unprocessed ToolTalk message.
1408 Unprocessed messages are messages that didn't match any patterns.
1409 */ );
1410   Vtooltalk_unprocessed_message_hook = Qnil;
1411
1412   Tooltalk_Message_plist_str = build_string ("Tooltalk Message plist");
1413   Tooltalk_Pattern_plist_str = build_string ("Tooltalk Pattern p plist");
1414
1415   staticpro(&Tooltalk_Message_plist_str);
1416   staticpro(&Tooltalk_Pattern_plist_str);
1417
1418 #define MAKE_CONSTANT(name) do { \
1419     defsymbol (&Q_ ## name, #name); \
1420     Fset (Q_ ## name, make_int (name)); \
1421   } while (0)
1422
1423   MAKE_CONSTANT (TT_MODE_UNDEFINED);
1424   MAKE_CONSTANT (TT_IN);
1425   MAKE_CONSTANT (TT_OUT);
1426   MAKE_CONSTANT (TT_INOUT);
1427   MAKE_CONSTANT (TT_MODE_LAST);
1428
1429   MAKE_CONSTANT (TT_SCOPE_NONE);
1430   MAKE_CONSTANT (TT_SESSION);
1431   MAKE_CONSTANT (TT_FILE);
1432   MAKE_CONSTANT (TT_BOTH);
1433   MAKE_CONSTANT (TT_FILE_IN_SESSION);
1434
1435   MAKE_CONSTANT (TT_CLASS_UNDEFINED);
1436   MAKE_CONSTANT (TT_NOTICE);
1437   MAKE_CONSTANT (TT_REQUEST);
1438   MAKE_CONSTANT (TT_CLASS_LAST);
1439
1440   MAKE_CONSTANT (TT_CATEGORY_UNDEFINED);
1441   MAKE_CONSTANT (TT_OBSERVE);
1442   MAKE_CONSTANT (TT_HANDLE);
1443   MAKE_CONSTANT (TT_CATEGORY_LAST);
1444
1445   MAKE_CONSTANT (TT_PROCEDURE);
1446   MAKE_CONSTANT (TT_OBJECT);
1447   MAKE_CONSTANT (TT_HANDLER);
1448   MAKE_CONSTANT (TT_OTYPE);
1449   MAKE_CONSTANT (TT_ADDRESS_LAST);
1450
1451   MAKE_CONSTANT (TT_CREATED);
1452   MAKE_CONSTANT (TT_SENT);
1453   MAKE_CONSTANT (TT_HANDLED);
1454   MAKE_CONSTANT (TT_FAILED);
1455   MAKE_CONSTANT (TT_QUEUED);
1456   MAKE_CONSTANT (TT_STARTED);
1457   MAKE_CONSTANT (TT_REJECTED);
1458   MAKE_CONSTANT (TT_STATE_LAST);
1459
1460   MAKE_CONSTANT (TT_DISCARD);
1461   MAKE_CONSTANT (TT_QUEUE);
1462   MAKE_CONSTANT (TT_START);
1463
1464 #undef MAKE_CONSTANT
1465
1466   staticpro (&Vtooltalk_message_gcpro);
1467   staticpro (&Vtooltalk_pattern_gcpro);
1468   Vtooltalk_message_gcpro =
1469     make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
1470   Vtooltalk_pattern_gcpro =
1471     make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
1472 }