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

   1 /* Tooltalk support for Emacs.
   2    Copyright (C) 1993, 1994 Sun Microsystems, Inc.
   3    Copyright (C) 1995 Free Software Foundation, Inc.
   4
   5 This file is part of XEmacs.
   6
   7 XEmacs is free software; you can redistribute it and/or modify it
   8 under the terms of the GNU General Public License as published by the
   9 Free Software Foundation; either version 2, or (at your option) any
  10 later version.
  11
  12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
  13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with XEmacs; see the file COPYING.  If not, write to
  19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  20 Boston, MA 02111-1307, USA.  */
  21
  22 /* Synched up with: Not in FSF. */
  23
  24 /* Written by John Rose <john.rose@eng.sun.com>.
  25    Heavily modified and cleaned up by Ben Wing <ben@xemacs.org>. */
  26
  27 #include <config.h>
  28 #include "lisp.h"
  29
  30 #include <X11/Xlib.h>
  31
  32 #include "buffer.h"
  33 #include "elhash.h"
  34 #include "process.h"
  35 #include "tooltalk.h"
  36
  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)
 155 {
 156   mark_object (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, 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)
 229 {
 230   mark_object (XTOOLTALK_PATTERN (obj)->callback);
 231   return XTOOLTALK_PATTERN (obj)->plist_sym;
 232 }
 233
 234 static void
 235 print_tooltalk_pattern (Lisp_Object obj, Lisp_Object printcharfun,
 236                         int escapeflag)
 237 {
 238   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, 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
1260   /* tt_open() messes with our signal handler flags (at least when no
1261      ttsessions is running on the machine), therefore we save the
1262      actions and restore them after the call */
1263 #ifdef HAVE_SIGPROCMASK
1264   {
1265     struct sigaction ActSIGQUIT;
1266     struct sigaction ActSIGINT;
1267     struct sigaction ActSIGCHLD;
1268     sigaction (SIGQUIT, NULL, &ActSIGQUIT);
1269     sigaction (SIGINT, NULL, &ActSIGINT);
1270     sigaction (SIGCHLD, NULL, &ActSIGCHLD);
1271 #endif
1272   retval = tt_open ();
1273 #ifdef HAVE_SIGPROCMASK
1274     sigaction (SIGQUIT, &ActSIGQUIT, NULL);
1275     sigaction (SIGINT, &ActSIGINT, NULL);
1276     sigaction (SIGCHLD, &ActSIGCHLD, NULL);
1277   }
1278 #endif
1279
1280
1281   if (tt_ptr_error (retval) != TT_OK)
1282     return;
1283
1284   Vtooltalk_fd = make_int (tt_fd ());
1285
1286   tt_session_join (tt_default_session ());
1287
1288   lp = connect_to_file_descriptor (build_string ("tooltalk"), Qnil,
1289                                    Vtooltalk_fd, Vtooltalk_fd);
1290   if (!NILP (lp))
1291     {
1292       /* Don't ask the user for confirmation when exiting Emacs */
1293       Fprocess_kill_without_query (lp, Qnil);
1294       XSETSUBR (fil, &SFreceive_tooltalk_message);
1295       set_process_filter (lp, fil, 1);
1296     }
1297   else
1298     {
1299       tt_close ();
1300       Vtooltalk_fd = Qnil;
1301       return;
1302     }
1303
1304 #if defined (SOLARIS2)
1305   /* Apparently the tt_message_send_on_exit() function does not exist
1306      under SunOS 4.x or IRIX 5 or various other non-Solaris-2 systems.
1307      No big deal if we don't do the following under those systems. */
1308   {
1309     Tt_message exit_msg = tt_message_create ();
1310
1311     tt_message_op_set (exit_msg, "emacs-aborted");
1312     tt_message_scope_set (exit_msg, TT_SESSION);
1313     tt_message_class_set (exit_msg, TT_NOTICE);
1314     tt_message_send_on_exit (exit_msg);
1315     tt_message_destroy (exit_msg);
1316   }
1317 #endif
1318 }
1319
1320 DEFUN ("tooltalk-open-connection", Ftooltalk_open_connection, 0, 0, 0, /*
1321 Opens a connection to the ToolTalk server.
1322 Returns t if successful, nil otherwise.
1323 */
1324        ())
1325 {
1326   if (!NILP (Vtooltalk_fd))
1327     error ("Already connected to ToolTalk.");
1328   if (noninteractive)
1329     error ("Can't connect to ToolTalk in batch mode.");
1330   init_tooltalk ();
1331   return NILP (Vtooltalk_fd) ? Qnil : Qt;
1332 }
1333
1334
1335 void
1336 syms_of_tooltalk (void)
1337 {
1338   defsymbol (&Qtooltalk_messagep, "tooltalk-message-p");
1339   DEFSUBR (Ftooltalk_message_p);
1340   defsymbol (&Qtooltalk_patternp, "tooltalk-pattern-p");
1341   DEFSUBR (Ftooltalk_pattern_p);
1342   defsymbol (&Qtooltalk_message_handler_hook, "tooltalk-message-handler-hook");
1343   defsymbol (&Qtooltalk_pattern_handler_hook, "tooltalk-pattern-handler-hook");
1344   defsymbol (&Qtooltalk_unprocessed_message_hook,
1345              "tooltalk-unprocessed-message-hook");
1346
1347   DEFSUBR (Freceive_tooltalk_message);
1348   DEFSUBR (Fcreate_tooltalk_message);
1349   DEFSUBR (Fdestroy_tooltalk_message);
1350   DEFSUBR (Fadd_tooltalk_message_arg);
1351   DEFSUBR (Fget_tooltalk_message_attribute);
1352   DEFSUBR (Fset_tooltalk_message_attribute);
1353   DEFSUBR (Fsend_tooltalk_message);
1354   DEFSUBR (Freturn_tooltalk_message);
1355   DEFSUBR (Fcreate_tooltalk_pattern);
1356   DEFSUBR (Fdestroy_tooltalk_pattern);
1357   DEFSUBR (Fadd_tooltalk_pattern_attribute);
1358   DEFSUBR (Fadd_tooltalk_pattern_arg);
1359   DEFSUBR (Fregister_tooltalk_pattern);
1360   DEFSUBR (Funregister_tooltalk_pattern);
1361   DEFSUBR (Ftooltalk_pattern_plist_get);
1362   DEFSUBR (Ftooltalk_pattern_prop_set);
1363   DEFSUBR (Ftooltalk_pattern_prop_get);
1364   DEFSUBR (Ftooltalk_default_procid);
1365   DEFSUBR (Ftooltalk_default_session);
1366   DEFSUBR (Ftooltalk_open_connection);
1367
1368   defsymbol (&Qreceive_tooltalk_message, "receive-tooltalk-message");
1369   defsymbol (&Qtt_address, "address");
1370   defsymbol (&Qtt_args_count, "args_count");
1371   defsymbol (&Qtt_arg_bval, "arg_bval");
1372   defsymbol (&Qtt_arg_ival, "arg_ival");
1373   defsymbol (&Qtt_arg_mode, "arg_mode");
1374   defsymbol (&Qtt_arg_type, "arg_type");
1375   defsymbol (&Qtt_arg_val, "arg_val");
1376   defsymbol (&Qtt_class, "class");
1377   defsymbol (&Qtt_category, "category");
1378   defsymbol (&Qtt_disposition, "disposition");
1379   defsymbol (&Qtt_file, "file");
1380   defsymbol (&Qtt_gid, "gid");
1381   defsymbol (&Qtt_handler, "handler");
1382   defsymbol (&Qtt_handler_ptype, "handler_ptype");
1383   defsymbol (&Qtt_object, "object");
1384   defsymbol (&Qtt_op, "op");
1385   defsymbol (&Qtt_opnum, "opnum");
1386   defsymbol (&Qtt_otype, "otype");
1387   defsymbol (&Qtt_scope, "scope");
1388   defsymbol (&Qtt_sender, "sender");
1389   defsymbol (&Qtt_sender_ptype, "sender_ptype");
1390   defsymbol (&Qtt_session, "session");
1391   defsymbol (&Qtt_state, "state");
1392   defsymbol (&Qtt_status, "status");
1393   defsymbol (&Qtt_status_string, "status_string");
1394   defsymbol (&Qtt_uid, "uid");
1395   defsymbol (&Qtt_callback, "callback");
1396   defsymbol (&Qtt_prop, "prop");
1397   defsymbol (&Qtt_plist, "plist");
1398   defsymbol (&Qtt_reject, "reject");
1399   defsymbol (&Qtt_reply, "reply");
1400   defsymbol (&Qtt_fail, "fail");
1401
1402   deferror (&Qtooltalk_error, "tooltalk-error", "ToolTalk error", Qio_error);
1403 }
1404
1405 void
1406 vars_of_tooltalk (void)
1407 {
1408   Fprovide (intern ("tooltalk"));
1409
1410   DEFVAR_LISP ("tooltalk-fd", &Vtooltalk_fd /*
1411 File descriptor returned by tt_initialize; nil if not connected to ToolTalk.
1412 */ );
1413   Vtooltalk_fd = Qnil;
1414
1415   DEFVAR_LISP ("tooltalk-message-handler-hook",
1416               &Vtooltalk_message_handler_hook /*
1417 List of functions to be applied to each ToolTalk message reply received.
1418 This will always occur as a result of our sending a request message.
1419 Functions will be called with two arguments, the message and the
1420 corresponding pattern.  This hook will not be called if the request
1421 message was created without a C-level callback function (see
1422 `tooltalk-unprocessed-message-hook').
1423 */ );
1424   Vtooltalk_message_handler_hook = Qnil;
1425
1426   DEFVAR_LISP ("tooltalk-pattern-handler-hook",
1427               &Vtooltalk_pattern_handler_hook /*
1428 List of functions to be applied to each pattern-matching ToolTalk message.
1429 This is all messages except those handled by `tooltalk-message-handler-hook'.
1430 Functions will be called with two arguments, the message and the
1431 corresponding pattern.
1432 */ );
1433   Vtooltalk_pattern_handler_hook = Qnil;
1434
1435   DEFVAR_LISP ("tooltalk-unprocessed-message-hook",
1436               &Vtooltalk_unprocessed_message_hook /*
1437 List of functions to be applied to each unprocessed ToolTalk message.
1438 Unprocessed messages are messages that didn't match any patterns.
1439 */ );
1440   Vtooltalk_unprocessed_message_hook = Qnil;
1441
1442   Tooltalk_Message_plist_str = build_string ("Tooltalk Message plist");
1443   Tooltalk_Pattern_plist_str = build_string ("Tooltalk Pattern p plist");
1444
1445   staticpro(&Tooltalk_Message_plist_str);
1446   staticpro(&Tooltalk_Pattern_plist_str);
1447
1448 #define MAKE_CONSTANT(name) do { \
1449     defsymbol (&Q_ ## name, #name); \
1450     Fset (Q_ ## name, make_int (name)); \
1451   } while (0)
1452
1453   MAKE_CONSTANT (TT_MODE_UNDEFINED);
1454   MAKE_CONSTANT (TT_IN);
1455   MAKE_CONSTANT (TT_OUT);
1456   MAKE_CONSTANT (TT_INOUT);
1457   MAKE_CONSTANT (TT_MODE_LAST);
1458
1459   MAKE_CONSTANT (TT_SCOPE_NONE);
1460   MAKE_CONSTANT (TT_SESSION);
1461   MAKE_CONSTANT (TT_FILE);
1462   MAKE_CONSTANT (TT_BOTH);
1463   MAKE_CONSTANT (TT_FILE_IN_SESSION);
1464
1465   MAKE_CONSTANT (TT_CLASS_UNDEFINED);
1466   MAKE_CONSTANT (TT_NOTICE);
1467   MAKE_CONSTANT (TT_REQUEST);
1468   MAKE_CONSTANT (TT_CLASS_LAST);
1469
1470   MAKE_CONSTANT (TT_CATEGORY_UNDEFINED);
1471   MAKE_CONSTANT (TT_OBSERVE);
1472   MAKE_CONSTANT (TT_HANDLE);
1473   MAKE_CONSTANT (TT_CATEGORY_LAST);
1474
1475   MAKE_CONSTANT (TT_PROCEDURE);
1476   MAKE_CONSTANT (TT_OBJECT);
1477   MAKE_CONSTANT (TT_HANDLER);
1478   MAKE_CONSTANT (TT_OTYPE);
1479   MAKE_CONSTANT (TT_ADDRESS_LAST);
1480
1481   MAKE_CONSTANT (TT_CREATED);
1482   MAKE_CONSTANT (TT_SENT);
1483   MAKE_CONSTANT (TT_HANDLED);
1484   MAKE_CONSTANT (TT_FAILED);
1485   MAKE_CONSTANT (TT_QUEUED);
1486   MAKE_CONSTANT (TT_STARTED);
1487   MAKE_CONSTANT (TT_REJECTED);
1488   MAKE_CONSTANT (TT_STATE_LAST);
1489
1490   MAKE_CONSTANT (TT_DISCARD);
1491   MAKE_CONSTANT (TT_QUEUE);
1492   MAKE_CONSTANT (TT_START);
1493
1494 #undef MAKE_CONSTANT
1495
1496   staticpro (&Vtooltalk_message_gcpro);
1497   staticpro (&Vtooltalk_pattern_gcpro);
1498   Vtooltalk_message_gcpro =
1499     make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
1500   Vtooltalk_pattern_gcpro =
1501     make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
1502 }