1 /* Tooltalk support for Emacs.
2 Copyright (C) 1993, 1994 Sun Microsystems, Inc.
3 Copyright (C) 1995 Free Software Foundation, Inc.
5 This file is part of XEmacs.
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
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
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. */
22 /* Synched up with: Not in FSF. */
24 /* Written by John Rose <john.rose@eng.sun.com>.
25 Heavily modified and cleaned up by Ben Wing <ben@xemacs.org>. */
36 #include "syssignal.h"
38 Lisp_Object Vtooltalk_fd;
41 static FILE *tooltalk_log_file;
45 Vtooltalk_message_handler_hook,
46 Vtooltalk_pattern_handler_hook,
47 Vtooltalk_unprocessed_message_hook;
50 Qtooltalk_message_handler_hook,
51 Qtooltalk_pattern_handler_hook,
52 Qtooltalk_unprocessed_message_hook;
55 Qreceive_tooltalk_message,
86 Qtt_reject, /* return-tooltalk-message */
90 Q_TT_MODE_UNDEFINED, /* enum Tt_mode */
96 Q_TT_SCOPE_NONE, /* enum Tt_scope */
100 Q_TT_FILE_IN_SESSION,
102 Q_TT_CLASS_UNDEFINED, /* enum Tt_class */
107 Q_TT_CATEGORY_UNDEFINED, /* enum Tt_category */
112 Q_TT_PROCEDURE, /* typedef enum Tt_address */
118 Q_TT_CREATED, /* enum Tt_state */
127 Q_TT_DISCARD, /* enum Tt_disposition */
131 static Lisp_Object Tooltalk_Message_plist_str, Tooltalk_Pattern_plist_str;
133 Lisp_Object Qtooltalk_error;
135 /* Used to GCPRO tooltalk message and pattern objects while
136 they're sitting inside of some active tooltalk message or pattern.
137 There may not be any other pointers to these objects. */
138 Lisp_Object Vtooltalk_message_gcpro, Vtooltalk_pattern_gcpro;
142 /* machinery for tooltalk-message type */
145 Lisp_Object Qtooltalk_messagep;
147 struct Lisp_Tooltalk_Message
149 struct lcrecord_header header;
150 Lisp_Object plist_sym, callback;
155 mark_tooltalk_message (Lisp_Object obj)
157 mark_object (XTOOLTALK_MESSAGE (obj)->callback);
158 return XTOOLTALK_MESSAGE (obj)->plist_sym;
162 print_tooltalk_message (Lisp_Object obj, Lisp_Object printcharfun,
165 Lisp_Tooltalk_Message *p = XTOOLTALK_MESSAGE (obj);
170 error ("printing unreadable object #<tooltalk_message 0x%x>",
173 sprintf (buf, "#<tooltalk_message id:0x%lx 0x%x>", (long) (p->m), p->header.uid);
174 write_c_string (buf, printcharfun);
177 DEFINE_LRECORD_IMPLEMENTATION ("tooltalk-message", tooltalk_message,
178 mark_tooltalk_message, print_tooltalk_message,
180 Lisp_Tooltalk_Message);
183 make_tooltalk_message (Tt_message m)
186 Lisp_Tooltalk_Message *msg =
187 alloc_lcrecord_type (Lisp_Tooltalk_Message, &lrecord_tooltalk_message);
190 msg->callback = Qnil;
191 msg->plist_sym = Fmake_symbol (Tooltalk_Message_plist_str);
192 XSETTOOLTALK_MESSAGE (val, msg);
197 unbox_tooltalk_message (Lisp_Object msg)
199 CHECK_TOOLTALK_MESSAGE (msg);
200 return XTOOLTALK_MESSAGE (msg)->m;
203 DEFUN ("tooltalk-message-p", Ftooltalk_message_p, 1, 1, 0, /*
204 Return non-nil if OBJECT is a tooltalk message.
208 return TOOLTALK_MESSAGEP (object) ? Qt : Qnil;
215 /* machinery for tooltalk-pattern type */
218 Lisp_Object Qtooltalk_patternp;
220 struct Lisp_Tooltalk_Pattern
222 struct lcrecord_header header;
223 Lisp_Object plist_sym, callback;
228 mark_tooltalk_pattern (Lisp_Object obj)
230 mark_object (XTOOLTALK_PATTERN (obj)->callback);
231 return XTOOLTALK_PATTERN (obj)->plist_sym;
235 print_tooltalk_pattern (Lisp_Object obj, Lisp_Object printcharfun,
238 Lisp_Tooltalk_Pattern *p = XTOOLTALK_PATTERN (obj);
243 error ("printing unreadable object #<tooltalk_pattern 0x%x>",
246 sprintf (buf, "#<tooltalk_pattern id:0x%lx 0x%x>", (long) (p->p), p->header.uid);
247 write_c_string (buf, printcharfun);
250 DEFINE_LRECORD_IMPLEMENTATION ("tooltalk-pattern", tooltalk_pattern,
251 mark_tooltalk_pattern, print_tooltalk_pattern,
253 Lisp_Tooltalk_Pattern);
256 make_tooltalk_pattern (Tt_pattern p)
258 Lisp_Tooltalk_Pattern *pat =
259 alloc_lcrecord_type (Lisp_Tooltalk_Pattern, &lrecord_tooltalk_pattern);
263 pat->callback = Qnil;
264 pat->plist_sym = Fmake_symbol (Tooltalk_Pattern_plist_str);
266 XSETTOOLTALK_PATTERN (val, pat);
271 unbox_tooltalk_pattern (Lisp_Object pattern)
273 CHECK_TOOLTALK_PATTERN (pattern);
274 return XTOOLTALK_PATTERN (pattern)->p;
277 DEFUN ("tooltalk-pattern-p", Ftooltalk_pattern_p, 1, 1, 0, /*
278 Return non-nil if OBJECT is a tooltalk pattern.
282 return TOOLTALK_PATTERNP (object) ? Qt : Qnil;
289 tooltalk_constant_value (Lisp_Object s)
293 else if (SYMBOLP (s))
294 return XINT (XSYMBOL (s)->value);
296 return 0; /* should never occur */
300 check_status (Tt_status st)
303 signal_error (Qtooltalk_error,
304 Fcons (build_string (tt_status_message (st)), Qnil));
307 DEFUN ("receive-tooltalk-message", Freceive_tooltalk_message, 0, 2, 0, /*
308 Run tt_message_receive().
309 This function is the process handler for the ToolTalk connection process.
313 /* This function can GC */
314 Tt_message mess = tt_message_receive ();
315 Lisp_Object message_ = make_tooltalk_message (mess);
319 if (mess != NULL && !NILP (Vtooltalk_unprocessed_message_hook))
320 va_run_hook_with_args (Qtooltalk_unprocessed_message_hook, 1, message_);
323 /* see comment in event-stream.c about this return value. */
327 static Tt_callback_action
328 tooltalk_message_callback (Tt_message m, Tt_pattern p)
330 /* This function can GC */
332 Lisp_Object message_;
334 struct gcpro gcpro1, gcpro2;
339 fprintf (tooltalk_log_file, "message_cb: %d\n", m);
340 fprintf (tooltalk_log_file, "op: %s (", tt_message_op (m));
341 for (j = tt_message_args_count (m), i = 0; i < j; i++) {
342 fprintf (tooltalk_log_file, "%s \"%s\"", tt_message_arg_type (m, i),
343 tt_message_arg_val (m, i));
344 fprintf (tooltalk_log_file, "%s", i == j-1 ? ")" : ", ");
346 fprintf (tooltalk_log_file, "\n\n");
347 fflush (tooltalk_log_file);
350 VOID_TO_LISP (message_, tt_message_user (m, TOOLTALK_MESSAGE_KEY));
351 pattern = make_tooltalk_pattern (p);
352 cb = XTOOLTALK_MESSAGE (message_)->callback;
353 GCPRO2 (message_, pattern);
354 if (!NILP (Vtooltalk_message_handler_hook))
355 va_run_hook_with_args (Qtooltalk_message_handler_hook, 2,
358 if ((SYMBOLP (cb) && EQ (Qt, Ffboundp (cb))) ||
359 (CONSP (cb) && EQ (Qlambda, Fcar (cb)) &&
360 !NILP (Flistp (Fcar (Fcdr (cb))))))
361 call2 (cb, message_, pattern);
364 tt_message_destroy (m);
365 Fremhash (message_, Vtooltalk_message_gcpro);
367 return TT_CALLBACK_PROCESSED;
370 static Tt_callback_action
371 tooltalk_pattern_callback (Tt_message m, Tt_pattern p)
373 /* This function can GC */
375 Lisp_Object message_;
377 struct gcpro gcpro1, gcpro2;
382 fprintf (tooltalk_log_file, "pattern_cb: %d\n", m);
383 fprintf (tooltalk_log_file, "op: %s (", tt_message_op (m));
384 for (j = tt_message_args_count (m), i = 0; i < j; i++) {
385 fprintf (tooltalk_log_file, "%s \"%s\"", tt_message_arg_type (m, i),
386 tt_message_arg_val (m, i));
387 fprintf (tooltalk_log_file, "%s", i == j-1 ? ")" : ", ");
389 fprintf (tooltalk_log_file, "\n\n");
390 fflush (tooltalk_log_file);
393 message_ = make_tooltalk_message (m);
394 VOID_TO_LISP (pattern, tt_pattern_user (p, TOOLTALK_PATTERN_KEY));
395 cb = XTOOLTALK_PATTERN (pattern)->callback;
396 GCPRO2 (message_, pattern);
397 if (!NILP (Vtooltalk_pattern_handler_hook))
398 va_run_hook_with_args (Qtooltalk_pattern_handler_hook, 2,
401 if (SYMBOLP (cb) && EQ (Qt, Ffboundp (cb)))
402 call2 (cb, message_, pattern);
405 tt_message_destroy (m);
406 return TT_CALLBACK_PROCESSED;
410 tt_mode_symbol (Tt_mode n)
414 case TT_MODE_UNDEFINED: return Q_TT_MODE_UNDEFINED;
415 case TT_IN: return Q_TT_IN;
416 case TT_OUT: return Q_TT_OUT;
417 case TT_INOUT: return Q_TT_INOUT;
418 case TT_MODE_LAST: return Q_TT_MODE_LAST;
419 default: return Qnil;
424 tt_scope_symbol (Tt_scope n)
428 case TT_SCOPE_NONE: return Q_TT_SCOPE_NONE;
429 case TT_SESSION: return Q_TT_SESSION;
430 case TT_FILE: return Q_TT_FILE;
431 case TT_BOTH: return Q_TT_BOTH;
432 case TT_FILE_IN_SESSION: return Q_TT_FILE_IN_SESSION;
433 default: return Qnil;
439 tt_class_symbol (Tt_class n)
443 case TT_CLASS_UNDEFINED: return Q_TT_CLASS_UNDEFINED;
444 case TT_NOTICE: return Q_TT_NOTICE;
445 case TT_REQUEST: return Q_TT_REQUEST;
446 case TT_CLASS_LAST: return Q_TT_CLASS_LAST;
447 default: return Qnil;
452 * This is not being used. Is that a mistake or is this function
453 * simply not necessary?
457 tt_category_symbol (Tt_category n)
461 case TT_CATEGORY_UNDEFINED: return Q_TT_CATEGORY_UNDEFINED;
462 case TT_OBSERVE: return Q_TT_OBSERVE;
463 case TT_HANDLE: return Q_TT_HANDLE;
464 case TT_CATEGORY_LAST: return Q_TT_CATEGORY_LAST;
465 default: return Qnil;
471 tt_address_symbol (Tt_address n)
475 case TT_PROCEDURE: return Q_TT_PROCEDURE;
476 case TT_OBJECT: return Q_TT_OBJECT;
477 case TT_HANDLER: return Q_TT_HANDLER;
478 case TT_OTYPE: return Q_TT_OTYPE;
479 case TT_ADDRESS_LAST: return Q_TT_ADDRESS_LAST;
480 default: return Qnil;
485 tt_state_symbol (Tt_state n)
489 case TT_CREATED: return Q_TT_CREATED;
490 case TT_SENT: return Q_TT_SENT;
491 case TT_HANDLED: return Q_TT_HANDLED;
492 case TT_FAILED: return Q_TT_FAILED;
493 case TT_QUEUED: return Q_TT_QUEUED;
494 case TT_STARTED: return Q_TT_STARTED;
495 case TT_REJECTED: return Q_TT_REJECTED;
496 case TT_STATE_LAST: return Q_TT_STATE_LAST;
497 default: return Qnil;
502 tt_build_string (char *s)
504 return build_string (s ? s : "");
508 tt_opnum_string (int n)
512 sprintf (buf, "%u", n);
513 return build_string (buf);
517 tt_message_arg_ival_string (Tt_message m, int n)
522 check_status (tt_message_arg_ival (m, n, &value));
523 long_to_string (buf, value);
524 return build_string (buf);
528 tt_message_arg_bval_vector (Tt_message m, int n)
530 /* !!#### This function has not been Mule-ized */
534 check_status (tt_message_arg_bval (m, n, &value, &len));
536 return make_string (value, len);
539 DEFUN ("get-tooltalk-message-attribute", Fget_tooltalk_message_attribute,
541 Return the indicated Tooltalk message attribute. Attributes are
542 identified by symbols with the same name (underscores and all) as the
543 suffix of the Tooltalk tt_message_<attribute> function that extracts the value.
544 String attribute values are copied, enumerated type values (except disposition)
545 are converted to symbols - e.g. TT_HANDLER is 'TT_HANDLER, uid and gid are
546 represented by fixnums (small integers), opnum is converted to a string,
547 and disposition is converted to a fixnum. We convert opnum (a C int) to a
548 string, e.g. 123 => "123" because there's no guarantee that opnums will fit
549 within the range of Lisp integers.
551 Use the 'plist attribute instead of the C API 'user attribute
552 for user defined message data. To retrieve the value of a message property
553 specify the indicator for argn. For example to get the value of a property
555 (get-tooltalk-message-attribute message 'plist 'rflag)
557 To get the value of a message argument use one of the 'arg_val (strings),
558 'arg_ival (integers), or 'arg_bval (strings with embedded nulls), attributes.
559 For example to get the integer value of the third argument:
561 (get-tooltalk-message-attribute message 'arg_ival 2)
563 As you can see, argument numbers are zero based. The type of each argument
564 can be retrieved with the 'arg_type attribute; however, Tooltalk doesn't
565 define any semantics for the string value of 'arg_type. Conventionally
566 "string" is used for strings and "int" for 32 bit integers. Note that
567 Emacs Lisp stores the lengths of strings explicitly (unlike C) so treating the
568 value returned by 'arg_bval like a string is fine.
570 (message_, attribute, argn))
572 Tt_message m = unbox_tooltalk_message (message_);
575 CHECK_SYMBOL (attribute);
576 if (EQ (attribute, (Qtt_arg_bval)) ||
577 EQ (attribute, (Qtt_arg_ival)) ||
578 EQ (attribute, (Qtt_arg_mode)) ||
579 EQ (attribute, (Qtt_arg_type)) ||
580 EQ (attribute, (Qtt_arg_val)))
586 if (!VALID_TOOLTALK_MESSAGEP (m))
589 else if (EQ (attribute, Qtt_arg_bval))
590 return tt_message_arg_bval_vector (m, n);
592 else if (EQ (attribute, Qtt_arg_ival))
593 return tt_message_arg_ival_string (m, n);
595 else if (EQ (attribute, Qtt_arg_mode))
596 return tt_mode_symbol (tt_message_arg_mode (m, n));
598 else if (EQ (attribute, Qtt_arg_type))
599 return tt_build_string (tt_message_arg_type (m, n));
601 else if (EQ (attribute, Qtt_arg_val))
602 return tt_message_arg_bval_vector (m, n);
604 else if (EQ (attribute, Qtt_args_count))
605 return make_int (tt_message_args_count (m));
607 else if (EQ (attribute, Qtt_address))
608 return tt_address_symbol (tt_message_address (m));
610 else if (EQ (attribute, Qtt_class))
611 return tt_class_symbol (tt_message_class (m));
613 else if (EQ (attribute, Qtt_disposition))
614 return make_int (tt_message_disposition (m));
616 else if (EQ (attribute, Qtt_file))
617 return tt_build_string (tt_message_file (m));
619 else if (EQ (attribute, Qtt_gid))
620 return make_int (tt_message_gid (m));
622 else if (EQ (attribute, Qtt_handler))
623 return tt_build_string (tt_message_handler (m));
625 else if (EQ (attribute, Qtt_handler_ptype))
626 return tt_build_string (tt_message_handler_ptype (m));
628 else if (EQ (attribute, Qtt_object))
629 return tt_build_string (tt_message_object (m));
631 else if (EQ (attribute, Qtt_op))
632 return tt_build_string (tt_message_op (m));
634 else if (EQ (attribute, Qtt_opnum))
635 return tt_opnum_string (tt_message_opnum (m));
637 else if (EQ (attribute, Qtt_otype))
638 return tt_build_string (tt_message_otype (m));
640 else if (EQ (attribute, Qtt_scope))
641 return tt_scope_symbol (tt_message_scope (m));
643 else if (EQ (attribute, Qtt_sender))
644 return tt_build_string (tt_message_sender (m));
646 else if (EQ (attribute, Qtt_sender_ptype))
647 return tt_build_string (tt_message_sender_ptype (m));
649 else if (EQ (attribute, Qtt_session))
650 return tt_build_string (tt_message_session (m));
652 else if (EQ (attribute, Qtt_state))
653 return tt_state_symbol (tt_message_state (m));
655 else if (EQ (attribute, Qtt_status))
656 return make_int (tt_message_status (m));
658 else if (EQ (attribute, Qtt_status_string))
659 return tt_build_string (tt_message_status_string (m));
661 else if (EQ (attribute, Qtt_uid))
662 return make_int (tt_message_uid (m));
664 else if (EQ (attribute, Qtt_callback))
665 return XTOOLTALK_MESSAGE (message_)->callback;
667 else if (EQ (attribute, Qtt_prop))
668 return Fget (XTOOLTALK_MESSAGE (message_)->plist_sym, argn, Qnil);
670 else if (EQ (attribute, Qtt_plist))
671 return Fcopy_sequence (Fsymbol_plist
672 (XTOOLTALK_MESSAGE (message_)->plist_sym));
675 signal_simple_error ("Invalid value for `get-tooltalk-message-attribute'",
681 DEFUN ("set-tooltalk-message-attribute", Fset_tooltalk_message_attribute,
683 Initialize one Tooltalk message attribute.
685 Attribute names and values are the same as for
686 `get-tooltalk-message-attribute'. A property list is provided for user
687 data (instead of the 'user message attribute); see
688 `get-tooltalk-message-attribute'.
690 The value of callback should be the name of a function of one argument.
691 It will be applied to the message and matching pattern each time the state of the
692 message changes. This is usually used to notice when the messages state has
693 changed to TT_HANDLED (or TT_FAILED), so that reply argument values
696 If one of the argument attributes is specified, 'arg_val, 'arg_ival, or
697 'arg_bval then argn must be the number of an already created argument.
698 New arguments can be added to a message with add-tooltalk-message-arg.
700 (value, message_, attribute, argn))
702 Tt_message m = unbox_tooltalk_message (message_);
704 Tt_status (*fun_str) (Tt_message, const char *) = 0;
706 CHECK_SYMBOL (attribute);
708 if (EQ (attribute, (Qtt_arg_bval)) ||
709 EQ (attribute, (Qtt_arg_ival)) ||
710 EQ (attribute, (Qtt_arg_val)))
716 if (!VALID_TOOLTALK_MESSAGEP (m))
719 if (EQ (attribute, Qtt_address))
721 CHECK_TOOLTALK_CONSTANT (value);
722 tt_message_address_set (m, (Tt_address) tooltalk_constant_value (value));
724 else if (EQ (attribute, Qtt_class))
726 CHECK_TOOLTALK_CONSTANT (value);
727 tt_message_class_set (m, (Tt_class) tooltalk_constant_value (value));
729 else if (EQ (attribute, Qtt_disposition))
731 CHECK_TOOLTALK_CONSTANT (value);
732 tt_message_disposition_set (m, ((Tt_disposition)
733 tooltalk_constant_value (value)));
735 else if (EQ (attribute, Qtt_scope))
737 CHECK_TOOLTALK_CONSTANT (value);
738 tt_message_scope_set (m, (Tt_scope) tooltalk_constant_value (value));
740 else if (EQ (attribute, Qtt_file))
741 fun_str = tt_message_file_set;
742 else if (EQ (attribute, Qtt_handler_ptype))
743 fun_str = tt_message_handler_ptype_set;
744 else if (EQ (attribute, Qtt_handler))
745 fun_str = tt_message_handler_set;
746 else if (EQ (attribute, Qtt_object))
747 fun_str = tt_message_object_set;
748 else if (EQ (attribute, Qtt_op))
749 fun_str = tt_message_op_set;
750 else if (EQ (attribute, Qtt_otype))
751 fun_str = tt_message_otype_set;
752 else if (EQ (attribute, Qtt_sender_ptype))
753 fun_str = tt_message_sender_ptype_set;
754 else if (EQ (attribute, Qtt_session))
755 fun_str = tt_message_session_set;
756 else if (EQ (attribute, Qtt_status_string))
757 fun_str = tt_message_status_string_set;
758 else if (EQ (attribute, Qtt_arg_bval))
761 Extcount value_ext_len;
762 CHECK_STRING (value);
763 TO_EXTERNAL_FORMAT (LISP_STRING, value,
764 ALLOCA, (value_ext, value_ext_len),
766 tt_message_arg_bval_set (m, n, (unsigned char *) value_ext, value_ext_len);
768 else if (EQ (attribute, Qtt_arg_ival))
771 tt_message_arg_ival_set (m, n, XINT (value));
773 else if (EQ (attribute, Qtt_arg_val))
775 const char *value_ext;
776 CHECK_STRING (value);
777 LISP_STRING_TO_EXTERNAL (value, value_ext, Qnative);
778 tt_message_arg_val_set (m, n, value_ext);
780 else if (EQ (attribute, Qtt_status))
783 tt_message_status_set (m, XINT (value));
785 else if (EQ (attribute, Qtt_callback))
787 CHECK_SYMBOL (value);
788 XTOOLTALK_MESSAGE (message_)->callback = value;
790 else if (EQ (attribute, Qtt_prop))
792 return Fput (XTOOLTALK_MESSAGE (message_)->plist_sym, argn, value);
795 signal_simple_error ("Invalid value for `set-tooltalk-message-attribute'",
800 const char *value_ext;
801 CHECK_STRING (value);
802 LISP_STRING_TO_EXTERNAL (value, value_ext, Qnative);
803 (*fun_str) (m, value_ext);
809 DEFUN ("return-tooltalk-message", Freturn_tooltalk_message, 1, 2, 0, /*
810 Send a reply to this message. The second argument can be
811 'reply, 'reject or 'fail; the default is 'reply. Before sending
812 a reply all message arguments whose mode is TT_INOUT or TT_OUT should
813 have been filled in - see set-tooltalk-message-attribute.
817 Tt_message m = unbox_tooltalk_message (message_);
824 if (!VALID_TOOLTALK_MESSAGEP (m))
826 else if (EQ (mode, Qtt_reply))
827 tt_message_reply (m);
828 else if (EQ (mode, Qtt_reject))
829 tt_message_reject (m);
830 else if (EQ (mode, Qtt_fail))
836 DEFUN ("create-tooltalk-message", Fcreate_tooltalk_message, 0, 1, 0, /*
837 Create a new tooltalk message.
838 The messages session attribute is initialized to the default session.
839 Other attributes can be initialized with `set-tooltalk-message-attribute'.
840 `make-tooltalk-message' is the preferred to create and initialize a message.
842 Optional arg NO-CALLBACK says don't add a C-level callback at all.
843 Normally don't do that; just don't specify the Lisp callback when
844 calling `make-tooltalk-message'.
848 Tt_message m = tt_message_create ();
849 Lisp_Object message_ = make_tooltalk_message (m);
850 if (NILP (no_callback))
852 tt_message_callback_add (m, tooltalk_message_callback);
854 tt_message_session_set (m, tt_default_session ());
855 tt_message_user_set (m, TOOLTALK_MESSAGE_KEY, LISP_TO_VOID (message_));
859 DEFUN ("destroy-tooltalk-message", Fdestroy_tooltalk_message, 1, 1, 0, /*
860 Apply tt_message_destroy() to the message.
861 It's not necessary to destroy messages after they've been processed by
862 a message or pattern callback; the Lisp/Tooltalk callback machinery does
867 Tt_message m = unbox_tooltalk_message (message_);
869 if (VALID_TOOLTALK_MESSAGEP (m))
870 /* #### Should we call Fremhash() here? It seems that
873 (send-tooltalk-message)
874 (destroy-tooltalk-message)
876 which would imply that destroying a sent ToolTalk message
877 doesn't actually destroy it; when a response is sent back,
878 the callback for the message will still be called.
880 But then maybe not: Maybe it really does destroy it,
881 and the reason for that paradigm is that the author
882 of `send-tooltalk-message' didn't really know what he
883 was talking about when he said that it's a good idea
884 to call `destroy-tooltalk-message' after sending it. */
885 tt_message_destroy (m);
891 DEFUN ("add-tooltalk-message-arg", Fadd_tooltalk_message_arg, 3, 4, 0, /*
892 Append one new argument to the message.
893 MODE must be one of TT_IN, TT_INOUT, or TT_OUT; VTYPE must be a string;
894 and VALUE can be a string or an integer. Tooltalk doesn't
895 define any semantics for VTYPE, so only the participants in the
896 protocol you're using need to agree what types mean (if anything).
897 Conventionally "string" is used for strings and "int" for 32 bit integers.
898 Arguments can initialized by providing a value or with
899 `set-tooltalk-message-attribute'. The latter is necessary if you
900 want to initialize the argument with a string that can contain
901 embedded nulls (use 'arg_bval).
903 (message_, mode, vtype, value))
905 Tt_message m = unbox_tooltalk_message (message_);
908 CHECK_STRING (vtype);
909 CHECK_TOOLTALK_CONSTANT (mode);
911 n = (Tt_mode) tooltalk_constant_value (mode);
913 if (!VALID_TOOLTALK_MESSAGEP (m))
916 const char *vtype_ext;
918 LISP_STRING_TO_EXTERNAL (vtype, vtype_ext, Qnative);
920 tt_message_arg_add (m, n, vtype_ext, NULL);
921 else if (STRINGP (value))
923 const char *value_ext;
924 LISP_STRING_TO_EXTERNAL (value, value_ext, Qnative);
925 tt_message_arg_add (m, n, vtype_ext, value_ext);
927 else if (INTP (value))
928 tt_message_iarg_add (m, n, vtype_ext, XINT (value));
934 DEFUN ("send-tooltalk-message", Fsend_tooltalk_message, 1, 1, 0, /*
935 Send the message on its way.
936 Once the message has been sent it's almost always a good idea to get rid of
937 it with `destroy-tooltalk-message'.
941 Tt_message m = unbox_tooltalk_message (message_);
943 if (VALID_TOOLTALK_MESSAGEP (m))
946 Fputhash (message_, Qnil, Vtooltalk_message_gcpro);
952 DEFUN ("create-tooltalk-pattern", Fcreate_tooltalk_pattern, 0, 0, 0, /*
953 Create a new Tooltalk pattern.
954 Its session attribute is initialized to be the default session.
958 Tt_pattern p = tt_pattern_create ();
959 Lisp_Object pattern = make_tooltalk_pattern (p);
961 tt_pattern_callback_add (p, tooltalk_pattern_callback);
962 tt_pattern_session_add (p, tt_default_session ());
963 tt_pattern_user_set (p, TOOLTALK_PATTERN_KEY, LISP_TO_VOID (pattern));
969 DEFUN ("destroy-tooltalk-pattern", Fdestroy_tooltalk_pattern, 1, 1, 0, /*
970 Apply tt_pattern_destroy() to the pattern.
971 This effectively unregisters the pattern.
975 Tt_pattern p = unbox_tooltalk_pattern (pattern);
977 if (VALID_TOOLTALK_PATTERNP (p))
979 tt_pattern_destroy (p);
980 Fremhash (pattern, Vtooltalk_pattern_gcpro);
987 DEFUN ("add-tooltalk-pattern-attribute", Fadd_tooltalk_pattern_attribute, 3, 3, 0, /*
988 Add one value to the indicated pattern attribute.
989 All Tooltalk pattern attributes are supported except 'user. The names
990 of attributes are the same as the Tooltalk accessors used to set them
991 less the "tooltalk_pattern_" prefix and the "_add" ...
993 (value, pattern, attribute))
995 Tt_pattern p = unbox_tooltalk_pattern (pattern);
997 CHECK_SYMBOL (attribute);
999 if (!VALID_TOOLTALK_PATTERNP (p))
1002 else if (EQ (attribute, Qtt_category))
1004 CHECK_TOOLTALK_CONSTANT (value);
1005 tt_pattern_category_set (p, ((Tt_category)
1006 tooltalk_constant_value (value)));
1008 else if (EQ (attribute, Qtt_address))
1010 CHECK_TOOLTALK_CONSTANT (value);
1011 tt_pattern_address_add (p, ((Tt_address)
1012 tooltalk_constant_value (value)));
1014 else if (EQ (attribute, Qtt_class))
1016 CHECK_TOOLTALK_CONSTANT (value);
1017 tt_pattern_class_add (p, (Tt_class) tooltalk_constant_value (value));
1019 else if (EQ (attribute, Qtt_disposition))
1021 CHECK_TOOLTALK_CONSTANT (value);
1022 tt_pattern_disposition_add (p, ((Tt_disposition)
1023 tooltalk_constant_value (value)));
1025 else if (EQ (attribute, Qtt_file))
1027 const char *value_ext;
1028 CHECK_STRING (value);
1029 LISP_STRING_TO_EXTERNAL (value, value_ext, Qnative);
1030 tt_pattern_file_add (p, value_ext);
1032 else if (EQ (attribute, Qtt_object))
1034 const char *value_ext;
1035 CHECK_STRING (value);
1036 LISP_STRING_TO_EXTERNAL (value, value_ext, Qnative);
1037 tt_pattern_object_add (p, value_ext);
1039 else if (EQ (attribute, Qtt_op))
1041 const char *value_ext;
1042 CHECK_STRING (value);
1043 LISP_STRING_TO_EXTERNAL (value, value_ext, Qnative);
1044 tt_pattern_op_add (p, value_ext);
1046 else if (EQ (attribute, Qtt_otype))
1048 const char *value_ext;
1049 CHECK_STRING (value);
1050 LISP_STRING_TO_EXTERNAL (value, value_ext, Qnative);
1051 tt_pattern_otype_add (p, value_ext);
1053 else if (EQ (attribute, Qtt_scope))
1055 CHECK_TOOLTALK_CONSTANT (value);
1056 tt_pattern_scope_add (p, (Tt_scope) tooltalk_constant_value (value));
1058 else if (EQ (attribute, Qtt_sender))
1060 const char *value_ext;
1061 CHECK_STRING (value);
1062 LISP_STRING_TO_EXTERNAL (value, value_ext, Qnative);
1063 tt_pattern_sender_add (p, value_ext);
1065 else if (EQ (attribute, Qtt_sender_ptype))
1067 const char *value_ext;
1068 CHECK_STRING (value);
1069 LISP_STRING_TO_EXTERNAL (value, value_ext, Qnative);
1070 tt_pattern_sender_ptype_add (p, value_ext);
1072 else if (EQ (attribute, Qtt_session))
1074 const char *value_ext;
1075 CHECK_STRING (value);
1076 LISP_STRING_TO_EXTERNAL (value, value_ext, Qnative);
1077 tt_pattern_session_add (p, value_ext);
1079 else if (EQ (attribute, Qtt_state))
1081 CHECK_TOOLTALK_CONSTANT (value);
1082 tt_pattern_state_add (p, (Tt_state) tooltalk_constant_value (value));
1084 else if (EQ (attribute, Qtt_callback))
1086 CHECK_SYMBOL (value);
1087 XTOOLTALK_PATTERN (pattern)->callback = value;
1094 DEFUN ("add-tooltalk-pattern-arg", Fadd_tooltalk_pattern_arg, 3, 4, 0, /*
1095 Add one fully specified argument to a tooltalk pattern.
1096 Mode must be one of TT_IN, TT_INOUT, or TT_OUT, type must be a string.
1097 Value can be an integer, string or nil. If value is an integer then
1098 an integer argument (tt_pattern_iarg_add) added otherwise a string argument
1099 is added. At present there's no way to add a binary data argument.
1101 (pattern, mode, vtype, value))
1103 Tt_pattern p = unbox_tooltalk_pattern (pattern);
1106 CHECK_STRING (vtype);
1107 CHECK_TOOLTALK_CONSTANT (mode);
1109 n = (Tt_mode) tooltalk_constant_value (mode);
1111 if (!VALID_TOOLTALK_PATTERNP (p))
1115 const char *vtype_ext;
1117 LISP_STRING_TO_EXTERNAL (vtype, vtype_ext, Qnative);
1119 tt_pattern_arg_add (p, n, vtype_ext, NULL);
1120 else if (STRINGP (value))
1122 const char *value_ext;
1123 LISP_STRING_TO_EXTERNAL (value, value_ext, Qnative);
1124 tt_pattern_arg_add (p, n, vtype_ext, value_ext);
1126 else if (INTP (value))
1127 tt_pattern_iarg_add (p, n, vtype_ext, XINT (value));
1134 DEFUN ("register-tooltalk-pattern", Fregister_tooltalk_pattern, 1, 1, 0, /*
1135 Emacs will begin receiving messages that match this pattern.
1139 Tt_pattern p = unbox_tooltalk_pattern (pattern);
1141 if (VALID_TOOLTALK_PATTERNP (p) && tt_pattern_register (p) == TT_OK)
1143 Fputhash (pattern, Qnil, Vtooltalk_pattern_gcpro);
1151 DEFUN ("unregister-tooltalk-pattern", Funregister_tooltalk_pattern, 1, 1, 0, /*
1152 Emacs will stop receiving messages that match this pattern.
1156 Tt_pattern p = unbox_tooltalk_pattern (pattern);
1158 if (VALID_TOOLTALK_PATTERNP (p))
1160 tt_pattern_unregister (p);
1161 Fremhash (pattern, Vtooltalk_pattern_gcpro);
1168 DEFUN ("tooltalk-pattern-prop-get", Ftooltalk_pattern_prop_get, 2, 2, 0, /*
1169 Return the value of PROPERTY in tooltalk pattern PATTERN.
1170 This is the last value set with `tooltalk-pattern-prop-set'.
1172 (pattern, property))
1174 CHECK_TOOLTALK_PATTERN (pattern);
1175 return Fget (XTOOLTALK_PATTERN (pattern)->plist_sym, property, Qnil);
1179 DEFUN ("tooltalk-pattern-prop-set", Ftooltalk_pattern_prop_set, 3, 3, 0, /*
1180 Set the value of PROPERTY to VALUE in tooltalk pattern PATTERN.
1181 It can be retrieved with `tooltalk-pattern-prop-get'.
1183 (pattern, property, value))
1185 CHECK_TOOLTALK_PATTERN (pattern);
1186 return Fput (XTOOLTALK_PATTERN (pattern)->plist_sym, property, value);
1190 DEFUN ("tooltalk-pattern-plist-get", Ftooltalk_pattern_plist_get, 1, 1, 0, /*
1191 Return the a list of all the properties currently set in PATTERN.
1195 CHECK_TOOLTALK_PATTERN (pattern);
1197 Fcopy_sequence (Fsymbol_plist (XTOOLTALK_PATTERN (pattern)->plist_sym));
1200 DEFUN ("tooltalk-default-procid", Ftooltalk_default_procid, 0, 0, 0, /*
1201 Return current default process identifier for your process.
1205 char *procid = tt_default_procid ();
1206 return procid ? build_string (procid) : Qnil;
1209 DEFUN ("tooltalk-default-session", Ftooltalk_default_session, 0, 0, 0, /*
1210 Return current default session identifier for the current default procid.
1214 char *session = tt_default_session ();
1215 return session ? build_string (session) : Qnil;
1219 init_tooltalk (void)
1221 /* This function can GC */
1227 /* tt_open() messes with our signal handler flags (at least when no
1228 ttsessions is running on the machine), therefore we save the
1229 actions and restore them after the call */
1230 #ifdef HAVE_SIGPROCMASK
1232 struct sigaction ActSIGQUIT;
1233 struct sigaction ActSIGINT;
1234 struct sigaction ActSIGCHLD;
1235 sigaction (SIGQUIT, NULL, &ActSIGQUIT);
1236 sigaction (SIGINT, NULL, &ActSIGINT);
1237 sigaction (SIGCHLD, NULL, &ActSIGCHLD);
1239 retval = tt_open ();
1240 #ifdef HAVE_SIGPROCMASK
1241 sigaction (SIGQUIT, &ActSIGQUIT, NULL);
1242 sigaction (SIGINT, &ActSIGINT, NULL);
1243 sigaction (SIGCHLD, &ActSIGCHLD, NULL);
1248 if (tt_ptr_error (retval) != TT_OK)
1251 Vtooltalk_fd = make_int (tt_fd ());
1253 tt_session_join (tt_default_session ());
1255 lp = connect_to_file_descriptor (build_string ("tooltalk"), Qnil,
1256 Vtooltalk_fd, Vtooltalk_fd);
1259 /* Don't ask the user for confirmation when exiting Emacs */
1260 Fprocess_kill_without_query (lp, Qnil);
1261 XSETSUBR (fil, &SFreceive_tooltalk_message);
1262 set_process_filter (lp, fil, 1);
1267 Vtooltalk_fd = Qnil;
1271 #if defined (SOLARIS2)
1272 /* Apparently the tt_message_send_on_exit() function does not exist
1273 under SunOS 4.x or IRIX 5 or various other non-Solaris-2 systems.
1274 No big deal if we don't do the following under those systems. */
1276 Tt_message exit_msg = tt_message_create ();
1278 tt_message_op_set (exit_msg, "emacs-aborted");
1279 tt_message_scope_set (exit_msg, TT_SESSION);
1280 tt_message_class_set (exit_msg, TT_NOTICE);
1281 tt_message_send_on_exit (exit_msg);
1282 tt_message_destroy (exit_msg);
1287 DEFUN ("tooltalk-open-connection", Ftooltalk_open_connection, 0, 0, 0, /*
1288 Opens a connection to the ToolTalk server.
1289 Returns t if successful, nil otherwise.
1293 if (!NILP (Vtooltalk_fd))
1294 error ("Already connected to ToolTalk.");
1296 error ("Can't connect to ToolTalk in batch mode.");
1298 return NILP (Vtooltalk_fd) ? Qnil : Qt;
1303 syms_of_tooltalk (void)
1305 INIT_LRECORD_IMPLEMENTATION (tooltalk_message);
1306 INIT_LRECORD_IMPLEMENTATION (tooltalk_pattern);
1308 defsymbol (&Qtooltalk_messagep, "tooltalk-message-p");
1309 DEFSUBR (Ftooltalk_message_p);
1310 defsymbol (&Qtooltalk_patternp, "tooltalk-pattern-p");
1311 DEFSUBR (Ftooltalk_pattern_p);
1312 defsymbol (&Qtooltalk_message_handler_hook, "tooltalk-message-handler-hook");
1313 defsymbol (&Qtooltalk_pattern_handler_hook, "tooltalk-pattern-handler-hook");
1314 defsymbol (&Qtooltalk_unprocessed_message_hook,
1315 "tooltalk-unprocessed-message-hook");
1317 DEFSUBR (Freceive_tooltalk_message);
1318 DEFSUBR (Fcreate_tooltalk_message);
1319 DEFSUBR (Fdestroy_tooltalk_message);
1320 DEFSUBR (Fadd_tooltalk_message_arg);
1321 DEFSUBR (Fget_tooltalk_message_attribute);
1322 DEFSUBR (Fset_tooltalk_message_attribute);
1323 DEFSUBR (Fsend_tooltalk_message);
1324 DEFSUBR (Freturn_tooltalk_message);
1325 DEFSUBR (Fcreate_tooltalk_pattern);
1326 DEFSUBR (Fdestroy_tooltalk_pattern);
1327 DEFSUBR (Fadd_tooltalk_pattern_attribute);
1328 DEFSUBR (Fadd_tooltalk_pattern_arg);
1329 DEFSUBR (Fregister_tooltalk_pattern);
1330 DEFSUBR (Funregister_tooltalk_pattern);
1331 DEFSUBR (Ftooltalk_pattern_plist_get);
1332 DEFSUBR (Ftooltalk_pattern_prop_set);
1333 DEFSUBR (Ftooltalk_pattern_prop_get);
1334 DEFSUBR (Ftooltalk_default_procid);
1335 DEFSUBR (Ftooltalk_default_session);
1336 DEFSUBR (Ftooltalk_open_connection);
1338 defsymbol (&Qreceive_tooltalk_message, "receive-tooltalk-message");
1339 defsymbol (&Qtt_address, "address");
1340 defsymbol (&Qtt_args_count, "args_count");
1341 defsymbol (&Qtt_arg_bval, "arg_bval");
1342 defsymbol (&Qtt_arg_ival, "arg_ival");
1343 defsymbol (&Qtt_arg_mode, "arg_mode");
1344 defsymbol (&Qtt_arg_type, "arg_type");
1345 defsymbol (&Qtt_arg_val, "arg_val");
1346 defsymbol (&Qtt_class, "class");
1347 defsymbol (&Qtt_category, "category");
1348 defsymbol (&Qtt_disposition, "disposition");
1349 defsymbol (&Qtt_file, "file");
1350 defsymbol (&Qtt_gid, "gid");
1351 defsymbol (&Qtt_handler, "handler");
1352 defsymbol (&Qtt_handler_ptype, "handler_ptype");
1353 defsymbol (&Qtt_object, "object");
1354 defsymbol (&Qtt_op, "op");
1355 defsymbol (&Qtt_opnum, "opnum");
1356 defsymbol (&Qtt_otype, "otype");
1357 defsymbol (&Qtt_scope, "scope");
1358 defsymbol (&Qtt_sender, "sender");
1359 defsymbol (&Qtt_sender_ptype, "sender_ptype");
1360 defsymbol (&Qtt_session, "session");
1361 defsymbol (&Qtt_state, "state");
1362 defsymbol (&Qtt_status, "status");
1363 defsymbol (&Qtt_status_string, "status_string");
1364 defsymbol (&Qtt_uid, "uid");
1365 defsymbol (&Qtt_callback, "callback");
1366 defsymbol (&Qtt_prop, "prop");
1367 defsymbol (&Qtt_plist, "plist");
1368 defsymbol (&Qtt_reject, "reject");
1369 defsymbol (&Qtt_reply, "reply");
1370 defsymbol (&Qtt_fail, "fail");
1372 DEFERROR (Qtooltalk_error, "ToolTalk error", Qio_error);
1376 vars_of_tooltalk (void)
1378 Fprovide (intern ("tooltalk"));
1380 DEFVAR_LISP ("tooltalk-fd", &Vtooltalk_fd /*
1381 File descriptor returned by tt_initialize; nil if not connected to ToolTalk.
1383 Vtooltalk_fd = Qnil;
1385 DEFVAR_LISP ("tooltalk-message-handler-hook",
1386 &Vtooltalk_message_handler_hook /*
1387 List of functions to be applied to each ToolTalk message reply received.
1388 This will always occur as a result of our sending a request message.
1389 Functions will be called with two arguments, the message and the
1390 corresponding pattern. This hook will not be called if the request
1391 message was created without a C-level callback function (see
1392 `tooltalk-unprocessed-message-hook').
1394 Vtooltalk_message_handler_hook = Qnil;
1396 DEFVAR_LISP ("tooltalk-pattern-handler-hook",
1397 &Vtooltalk_pattern_handler_hook /*
1398 List of functions to be applied to each pattern-matching ToolTalk message.
1399 This is all messages except those handled by `tooltalk-message-handler-hook'.
1400 Functions will be called with two arguments, the message and the
1401 corresponding pattern.
1403 Vtooltalk_pattern_handler_hook = Qnil;
1405 DEFVAR_LISP ("tooltalk-unprocessed-message-hook",
1406 &Vtooltalk_unprocessed_message_hook /*
1407 List of functions to be applied to each unprocessed ToolTalk message.
1408 Unprocessed messages are messages that didn't match any patterns.
1410 Vtooltalk_unprocessed_message_hook = Qnil;
1412 Tooltalk_Message_plist_str = build_string ("Tooltalk Message plist");
1413 Tooltalk_Pattern_plist_str = build_string ("Tooltalk Pattern p plist");
1415 staticpro(&Tooltalk_Message_plist_str);
1416 staticpro(&Tooltalk_Pattern_plist_str);
1418 #define MAKE_CONSTANT(name) do { \
1419 defsymbol (&Q_ ## name, #name); \
1420 Fset (Q_ ## name, make_int (name)); \
1423 MAKE_CONSTANT (TT_MODE_UNDEFINED);
1424 MAKE_CONSTANT (TT_IN);
1425 MAKE_CONSTANT (TT_OUT);
1426 MAKE_CONSTANT (TT_INOUT);
1427 MAKE_CONSTANT (TT_MODE_LAST);
1429 MAKE_CONSTANT (TT_SCOPE_NONE);
1430 MAKE_CONSTANT (TT_SESSION);
1431 MAKE_CONSTANT (TT_FILE);
1432 MAKE_CONSTANT (TT_BOTH);
1433 MAKE_CONSTANT (TT_FILE_IN_SESSION);
1435 MAKE_CONSTANT (TT_CLASS_UNDEFINED);
1436 MAKE_CONSTANT (TT_NOTICE);
1437 MAKE_CONSTANT (TT_REQUEST);
1438 MAKE_CONSTANT (TT_CLASS_LAST);
1440 MAKE_CONSTANT (TT_CATEGORY_UNDEFINED);
1441 MAKE_CONSTANT (TT_OBSERVE);
1442 MAKE_CONSTANT (TT_HANDLE);
1443 MAKE_CONSTANT (TT_CATEGORY_LAST);
1445 MAKE_CONSTANT (TT_PROCEDURE);
1446 MAKE_CONSTANT (TT_OBJECT);
1447 MAKE_CONSTANT (TT_HANDLER);
1448 MAKE_CONSTANT (TT_OTYPE);
1449 MAKE_CONSTANT (TT_ADDRESS_LAST);
1451 MAKE_CONSTANT (TT_CREATED);
1452 MAKE_CONSTANT (TT_SENT);
1453 MAKE_CONSTANT (TT_HANDLED);
1454 MAKE_CONSTANT (TT_FAILED);
1455 MAKE_CONSTANT (TT_QUEUED);
1456 MAKE_CONSTANT (TT_STARTED);
1457 MAKE_CONSTANT (TT_REJECTED);
1458 MAKE_CONSTANT (TT_STATE_LAST);
1460 MAKE_CONSTANT (TT_DISCARD);
1461 MAKE_CONSTANT (TT_QUEUE);
1462 MAKE_CONSTANT (TT_START);
1464 #undef MAKE_CONSTANT
1466 staticpro (&Vtooltalk_message_gcpro);
1467 staticpro (&Vtooltalk_pattern_gcpro);
1468 Vtooltalk_message_gcpro =
1469 make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
1470 Vtooltalk_pattern_gcpro =
1471 make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);