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