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