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>. */
37 Lisp_Object Vtooltalk_fd;
40 static FILE *tooltalk_log_file;
44 Vtooltalk_message_handler_hook,
45 Vtooltalk_pattern_handler_hook,
46 Vtooltalk_unprocessed_message_hook;
49 Qtooltalk_message_handler_hook,
50 Qtooltalk_pattern_handler_hook,
51 Qtooltalk_unprocessed_message_hook;
54 Qreceive_tooltalk_message,
85 Qtt_reject, /* return-tooltalk-message */
89 Q_TT_MODE_UNDEFINED, /* enum Tt_mode */
95 Q_TT_SCOPE_NONE, /* enum Tt_scope */
101 Q_TT_CLASS_UNDEFINED, /* enum Tt_class */
106 Q_TT_CATEGORY_UNDEFINED, /* enum Tt_category */
111 Q_TT_PROCEDURE, /* typedef enum Tt_address */
117 Q_TT_CREATED, /* enum Tt_state */
126 Q_TT_DISCARD, /* enum Tt_disposition */
130 static Lisp_Object Tooltalk_Message_plist_str, Tooltalk_Pattern_plist_str;
132 Lisp_Object Qtooltalk_error;
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;
141 /* machinery for tooltalk-message type */
144 Lisp_Object Qtooltalk_messagep;
146 struct Lisp_Tooltalk_Message
148 struct lcrecord_header header;
149 Lisp_Object plist_sym, callback;
154 mark_tooltalk_message (Lisp_Object obj)
156 mark_object (XTOOLTALK_MESSAGE (obj)->callback);
157 return XTOOLTALK_MESSAGE (obj)->plist_sym;
161 print_tooltalk_message (Lisp_Object obj, Lisp_Object printcharfun,
164 struct Lisp_Tooltalk_Message *p = XTOOLTALK_MESSAGE (obj);
169 error ("printing unreadable object #<tooltalk_message 0x%x>",
172 sprintf (buf, "#<tooltalk_message id:0x%lx 0x%x>", (long) (p->m), p->header.uid);
173 write_c_string (buf, printcharfun);
176 DEFINE_LRECORD_IMPLEMENTATION ("tooltalk-message", tooltalk_message,
177 mark_tooltalk_message, print_tooltalk_message,
179 struct Lisp_Tooltalk_Message);
182 make_tooltalk_message (Tt_message m)
185 struct Lisp_Tooltalk_Message *msg =
186 alloc_lcrecord_type (struct Lisp_Tooltalk_Message,
187 &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 struct 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 struct Lisp_Tooltalk_Pattern);
256 make_tooltalk_pattern (Tt_pattern p)
258 struct Lisp_Tooltalk_Pattern *pat =
259 alloc_lcrecord_type (struct Lisp_Tooltalk_Pattern,
260 &lrecord_tooltalk_pattern);
264 pat->callback = Qnil;
265 pat->plist_sym = Fmake_symbol (Tooltalk_Pattern_plist_str);
267 XSETTOOLTALK_PATTERN (val, pat);
272 unbox_tooltalk_pattern (Lisp_Object pattern)
274 CHECK_TOOLTALK_PATTERN (pattern);
275 return XTOOLTALK_PATTERN (pattern)->p;
278 DEFUN ("tooltalk-pattern-p", Ftooltalk_pattern_p, 1, 1, 0, /*
279 Return non-nil if OBJECT is a tooltalk pattern.
283 return TOOLTALK_PATTERNP (object) ? Qt : Qnil;
290 tooltalk_constant_value (Lisp_Object s)
294 else if (SYMBOLP (s))
295 return XINT (XSYMBOL (s)->value);
297 return 0; /* should never occur */
301 check_status (Tt_status st)
304 signal_error (Qtooltalk_error,
305 Fcons (build_string (tt_status_message (st)), Qnil));
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.
314 /* This function can GC */
315 Tt_message mess = tt_message_receive ();
316 Lisp_Object message_ = make_tooltalk_message (mess);
320 if (mess != NULL && !NILP (Vtooltalk_unprocessed_message_hook))
321 va_run_hook_with_args (Qtooltalk_unprocessed_message_hook, 1, message_);
324 /* see comment in event-stream.c about this return value. */
328 static Tt_callback_action
329 tooltalk_message_callback (Tt_message m, Tt_pattern p)
331 /* This function can GC */
333 Lisp_Object message_;
335 struct gcpro gcpro1, gcpro2;
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 ? ")" : ", ");
347 fprintf (tooltalk_log_file, "\n\n");
348 fflush (tooltalk_log_file);
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,
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);
365 tt_message_destroy (m);
366 Fremhash (message_, Vtooltalk_message_gcpro);
368 return TT_CALLBACK_PROCESSED;
371 static Tt_callback_action
372 tooltalk_pattern_callback (Tt_message m, Tt_pattern p)
374 /* This function can GC */
376 Lisp_Object message_;
378 struct gcpro gcpro1, gcpro2;
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 ? ")" : ", ");
390 fprintf (tooltalk_log_file, "\n\n");
391 fflush (tooltalk_log_file);
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,
402 if (SYMBOLP (cb) && EQ (Qt, Ffboundp (cb)))
403 call2 (cb, message_, pattern);
406 tt_message_destroy (m);
407 return TT_CALLBACK_PROCESSED;
411 tt_mode_symbol (Tt_mode n)
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;
425 tt_scope_symbol (Tt_scope n)
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;
440 tt_class_symbol (Tt_class n)
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;
453 * This is not being used. Is that a mistake or is this function
454 * simply not necessary?
458 tt_category_symbol (Tt_category n)
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;
472 tt_address_symbol (Tt_address n)
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;
486 tt_state_symbol (Tt_state n)
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;
503 tt_build_string (char *s)
505 return build_string (s ? s : "");
509 tt_opnum_string (int n)
513 sprintf (buf, "%u", n);
514 return build_string (buf);
518 tt_message_arg_ival_string (Tt_message m, int n)
523 check_status (tt_message_arg_ival (m, n, &value));
524 long_to_string (buf, value);
525 return build_string (buf);
529 tt_message_arg_bval_vector (Tt_message m, int n)
531 /* !!#### This function has not been Mule-ized */
535 check_status (tt_message_arg_bval (m, n, &value, &len));
537 return make_string (value, len);
540 DEFUN ("get-tooltalk-message-attribute", Fget_tooltalk_message_attribute,
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.
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
556 (get-tooltalk-message-attribute message 'plist 'rflag)
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:
562 (get-tooltalk-message-attribute message 'arg_ival 2)
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.
571 (message_, attribute, argn))
573 Tt_message m = unbox_tooltalk_message (message_);
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)))
587 if (!VALID_TOOLTALK_MESSAGEP (m))
590 else if (EQ (attribute, Qtt_arg_bval))
591 return tt_message_arg_bval_vector (m, n);
593 else if (EQ (attribute, Qtt_arg_ival))
594 return tt_message_arg_ival_string (m, n);
596 else if (EQ (attribute, Qtt_arg_mode))
597 return tt_mode_symbol (tt_message_arg_mode (m, n));
599 else if (EQ (attribute, Qtt_arg_type))
600 return tt_build_string (tt_message_arg_type (m, n));
602 else if (EQ (attribute, Qtt_arg_val))
603 return tt_message_arg_bval_vector (m, n);
605 else if (EQ (attribute, Qtt_args_count))
606 return make_int (tt_message_args_count (m));
608 else if (EQ (attribute, Qtt_address))
609 return tt_address_symbol (tt_message_address (m));
611 else if (EQ (attribute, Qtt_class))
612 return tt_class_symbol (tt_message_class (m));
614 else if (EQ (attribute, Qtt_disposition))
615 return make_int (tt_message_disposition (m));
617 else if (EQ (attribute, Qtt_file))
618 return tt_build_string (tt_message_file (m));
620 else if (EQ (attribute, Qtt_gid))
621 return make_int (tt_message_gid (m));
623 else if (EQ (attribute, Qtt_handler))
624 return tt_build_string (tt_message_handler (m));
626 else if (EQ (attribute, Qtt_handler_ptype))
627 return tt_build_string (tt_message_handler_ptype (m));
629 else if (EQ (attribute, Qtt_object))
630 return tt_build_string (tt_message_object (m));
632 else if (EQ (attribute, Qtt_op))
633 return tt_build_string (tt_message_op (m));
635 else if (EQ (attribute, Qtt_opnum))
636 return tt_opnum_string (tt_message_opnum (m));
638 else if (EQ (attribute, Qtt_otype))
639 return tt_build_string (tt_message_otype (m));
641 else if (EQ (attribute, Qtt_scope))
642 return tt_scope_symbol (tt_message_scope (m));
644 else if (EQ (attribute, Qtt_sender))
645 return tt_build_string (tt_message_sender (m));
647 else if (EQ (attribute, Qtt_sender_ptype))
648 return tt_build_string (tt_message_sender_ptype (m));
650 else if (EQ (attribute, Qtt_session))
651 return tt_build_string (tt_message_session (m));
653 else if (EQ (attribute, Qtt_state))
654 return tt_state_symbol (tt_message_state (m));
656 else if (EQ (attribute, Qtt_status))
657 return make_int (tt_message_status (m));
659 else if (EQ (attribute, Qtt_status_string))
660 return tt_build_string (tt_message_status_string (m));
662 else if (EQ (attribute, Qtt_uid))
663 return make_int (tt_message_uid (m));
665 else if (EQ (attribute, Qtt_callback))
666 return XTOOLTALK_MESSAGE (message_)->callback;
668 else if (EQ (attribute, Qtt_prop))
669 return Fget (XTOOLTALK_MESSAGE (message_)->plist_sym, argn, Qnil);
671 else if (EQ (attribute, Qtt_plist))
672 return Fcopy_sequence (Fsymbol_plist
673 (XTOOLTALK_MESSAGE (message_)->plist_sym));
676 signal_simple_error ("Invalid value for `get-tooltalk-message-attribute'",
682 DEFUN ("set-tooltalk-message-attribute", Fset_tooltalk_message_attribute,
684 Initialize one Tooltalk message attribute.
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'.
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
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.
701 (value, message_, attribute, argn))
703 Tt_message m = unbox_tooltalk_message (message_);
706 CHECK_SYMBOL (attribute);
707 if (EQ (attribute, (Qtt_arg_bval)) ||
708 EQ (attribute, (Qtt_arg_ival)) ||
709 EQ (attribute, (Qtt_arg_val)))
715 if (!VALID_TOOLTALK_MESSAGEP (m))
718 else if (EQ (attribute, Qtt_address))
720 CHECK_TOOLTALK_CONSTANT (value);
721 tt_message_address_set (m, (Tt_address) tooltalk_constant_value (value));
723 else if (EQ (attribute, Qtt_class))
725 CHECK_TOOLTALK_CONSTANT (value);
726 tt_message_class_set (m, (Tt_class) tooltalk_constant_value (value));
728 else if (EQ (attribute, Qtt_disposition))
730 CHECK_TOOLTALK_CONSTANT (value);
731 tt_message_disposition_set (m, ((Tt_disposition)
732 tooltalk_constant_value (value)));
734 else if (EQ (attribute, Qtt_file))
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);
741 else if (EQ (attribute, Qtt_handler_ptype))
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);
748 else if (EQ (attribute, Qtt_handler))
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);
755 else if (EQ (attribute, Qtt_object))
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);
762 else if (EQ (attribute, Qtt_op))
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);
769 else if (EQ (attribute, Qtt_otype))
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);
776 else if (EQ (attribute, Qtt_scope))
778 CHECK_TOOLTALK_CONSTANT (value);
779 tt_message_scope_set (m, (Tt_scope) tooltalk_constant_value (value));
781 else if (EQ (attribute, Qtt_sender_ptype))
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);
788 else if (EQ (attribute, Qtt_session))
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);
795 else if (EQ (attribute, Qtt_arg_bval))
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);
803 else if (EQ (attribute, Qtt_arg_ival))
806 tt_message_arg_ival_set (m, n, XINT (value));
808 else if (EQ (attribute, Qtt_arg_val))
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);
815 else if (EQ (attribute, Qtt_status))
818 tt_message_status_set (m, XINT (value));
820 else if (EQ (attribute, Qtt_status_string))
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);
827 else if (EQ (attribute, Qtt_callback))
829 CHECK_SYMBOL (value);
830 XTOOLTALK_MESSAGE (message_)->callback = value;
832 else if (EQ (attribute, Qtt_prop))
834 return Fput (XTOOLTALK_MESSAGE (message_)->plist_sym, argn, value);
837 signal_simple_error ("Invalid value for `set-tooltalk-message-attribute'",
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.
850 Tt_message m = unbox_tooltalk_message (message_);
857 if (!VALID_TOOLTALK_MESSAGEP (m))
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))
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.
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'.
881 Tt_message m = tt_message_create ();
882 Lisp_Object message_ = make_tooltalk_message (m);
883 if (NILP (no_callback))
885 tt_message_callback_add (m, tooltalk_message_callback);
887 tt_message_session_set (m, tt_default_session ());
888 tt_message_user_set (m, TOOLTALK_MESSAGE_KEY, LISP_TO_VOID (message_));
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
900 Tt_message m = unbox_tooltalk_message (message_);
902 if (VALID_TOOLTALK_MESSAGEP (m))
903 /* #### Should we call Fremhash() here? It seems that
906 (send-tooltalk-message)
907 (destroy-tooltalk-message)
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.
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);
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).
936 (message_, mode, vtype, value))
938 Tt_message m = unbox_tooltalk_message (message_);
941 CHECK_STRING (vtype);
942 CHECK_TOOLTALK_CONSTANT (mode);
944 n = (Tt_mode) tooltalk_constant_value (mode);
946 if (!VALID_TOOLTALK_MESSAGEP (m))
949 CONST char *vtype_ext;
951 GET_C_STRING_OS_DATA_ALLOCA (vtype, vtype_ext);
953 tt_message_arg_add (m, n, vtype_ext, NULL);
954 else if (STRINGP (value))
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);
960 else if (INTP (value))
961 tt_message_iarg_add (m, n, vtype_ext, XINT (value));
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'.
974 Tt_message m = unbox_tooltalk_message (message_);
976 if (VALID_TOOLTALK_MESSAGEP (m))
979 Fputhash (message_, Qnil, Vtooltalk_message_gcpro);
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.
991 Tt_pattern p = tt_pattern_create ();
992 Lisp_Object pattern = make_tooltalk_pattern (p);
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));
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.
1008 Tt_pattern p = unbox_tooltalk_pattern (pattern);
1010 if (VALID_TOOLTALK_PATTERNP (p))
1012 tt_pattern_destroy (p);
1013 Fremhash (pattern, Vtooltalk_pattern_gcpro);
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" ...
1026 (value, pattern, attribute))
1028 Tt_pattern p = unbox_tooltalk_pattern (pattern);
1030 CHECK_SYMBOL (attribute);
1032 if (!VALID_TOOLTALK_PATTERNP (p))
1035 else if (EQ (attribute, Qtt_category))
1037 CHECK_TOOLTALK_CONSTANT (value);
1038 tt_pattern_category_set (p, ((Tt_category)
1039 tooltalk_constant_value (value)));
1041 else if (EQ (attribute, Qtt_address))
1043 CHECK_TOOLTALK_CONSTANT (value);
1044 tt_pattern_address_add (p, ((Tt_address)
1045 tooltalk_constant_value (value)));
1047 else if (EQ (attribute, Qtt_class))
1049 CHECK_TOOLTALK_CONSTANT (value);
1050 tt_pattern_class_add (p, (Tt_class) tooltalk_constant_value (value));
1052 else if (EQ (attribute, Qtt_disposition))
1054 CHECK_TOOLTALK_CONSTANT (value);
1055 tt_pattern_disposition_add (p, ((Tt_disposition)
1056 tooltalk_constant_value (value)));
1058 else if (EQ (attribute, Qtt_file))
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);
1065 else if (EQ (attribute, Qtt_object))
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);
1072 else if (EQ (attribute, Qtt_op))
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);
1079 else if (EQ (attribute, Qtt_otype))
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);
1086 else if (EQ (attribute, Qtt_scope))
1088 CHECK_TOOLTALK_CONSTANT (value);
1089 tt_pattern_scope_add (p, (Tt_scope) tooltalk_constant_value (value));
1091 else if (EQ (attribute, Qtt_sender))
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);
1098 else if (EQ (attribute, Qtt_sender_ptype))
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);
1105 else if (EQ (attribute, Qtt_session))
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);
1112 else if (EQ (attribute, Qtt_state))
1114 CHECK_TOOLTALK_CONSTANT (value);
1115 tt_pattern_state_add (p, (Tt_state) tooltalk_constant_value (value));
1117 else if (EQ (attribute, Qtt_callback))
1119 CHECK_SYMBOL (value);
1120 XTOOLTALK_PATTERN (pattern)->callback = value;
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.
1134 (pattern, mode, vtype, value))
1136 Tt_pattern p = unbox_tooltalk_pattern (pattern);
1139 CHECK_STRING (vtype);
1140 CHECK_TOOLTALK_CONSTANT (mode);
1142 n = (Tt_mode) tooltalk_constant_value (mode);
1144 if (!VALID_TOOLTALK_PATTERNP (p))
1148 CONST char *vtype_ext;
1150 GET_C_STRING_OS_DATA_ALLOCA (vtype, vtype_ext);
1152 tt_pattern_arg_add (p, n, vtype_ext, NULL);
1153 else if (STRINGP (value))
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);
1159 else if (INTP (value))
1160 tt_pattern_iarg_add (p, n, vtype_ext, XINT (value));
1167 DEFUN ("register-tooltalk-pattern", Fregister_tooltalk_pattern, 1, 1, 0, /*
1168 Emacs will begin receiving messages that match this pattern.
1172 Tt_pattern p = unbox_tooltalk_pattern (pattern);
1174 if (VALID_TOOLTALK_PATTERNP (p) && tt_pattern_register (p) == TT_OK)
1176 Fputhash (pattern, Qnil, Vtooltalk_pattern_gcpro);
1184 DEFUN ("unregister-tooltalk-pattern", Funregister_tooltalk_pattern, 1, 1, 0, /*
1185 Emacs will stop receiving messages that match this pattern.
1189 Tt_pattern p = unbox_tooltalk_pattern (pattern);
1191 if (VALID_TOOLTALK_PATTERNP (p))
1193 tt_pattern_unregister (p);
1194 Fremhash (pattern, Vtooltalk_pattern_gcpro);
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'.
1205 (pattern, property))
1207 CHECK_TOOLTALK_PATTERN (pattern);
1208 return Fget (XTOOLTALK_PATTERN (pattern)->plist_sym, property, Qnil);
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'.
1216 (pattern, property, value))
1218 CHECK_TOOLTALK_PATTERN (pattern);
1219 return Fput (XTOOLTALK_PATTERN (pattern)->plist_sym, property, value);
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.
1228 CHECK_TOOLTALK_PATTERN (pattern);
1230 Fcopy_sequence (Fsymbol_plist (XTOOLTALK_PATTERN (pattern)->plist_sym));
1233 DEFUN ("tooltalk-default-procid", Ftooltalk_default_procid, 0, 0, 0, /*
1234 Return current default process identifier for your process.
1238 char *procid = tt_default_procid ();
1239 return procid ? build_string (procid) : Qnil;
1242 DEFUN ("tooltalk-default-session", Ftooltalk_default_session, 0, 0, 0, /*
1243 Return current default session identifier for the current default procid.
1247 char *session = tt_default_session ();
1248 return session ? build_string (session) : Qnil;
1252 init_tooltalk (void)
1254 /* This function can GC */
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
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);
1272 retval = tt_open ();
1273 #ifdef HAVE_SIGPROCMASK
1274 sigaction (SIGQUIT, &ActSIGQUIT, NULL);
1275 sigaction (SIGINT, &ActSIGINT, NULL);
1276 sigaction (SIGCHLD, &ActSIGCHLD, NULL);
1281 if (tt_ptr_error (retval) != TT_OK)
1284 Vtooltalk_fd = make_int (tt_fd ());
1286 tt_session_join (tt_default_session ());
1288 lp = connect_to_file_descriptor (build_string ("tooltalk"), Qnil,
1289 Vtooltalk_fd, Vtooltalk_fd);
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);
1300 Vtooltalk_fd = Qnil;
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. */
1309 Tt_message exit_msg = tt_message_create ();
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);
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.
1326 if (!NILP (Vtooltalk_fd))
1327 error ("Already connected to ToolTalk.");
1329 error ("Can't connect to ToolTalk in batch mode.");
1331 return NILP (Vtooltalk_fd) ? Qnil : Qt;
1336 syms_of_tooltalk (void)
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");
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);
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");
1402 deferror (&Qtooltalk_error, "tooltalk-error", "ToolTalk error", Qio_error);
1406 vars_of_tooltalk (void)
1408 Fprovide (intern ("tooltalk"));
1410 DEFVAR_LISP ("tooltalk-fd", &Vtooltalk_fd /*
1411 File descriptor returned by tt_initialize; nil if not connected to ToolTalk.
1413 Vtooltalk_fd = Qnil;
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').
1424 Vtooltalk_message_handler_hook = Qnil;
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.
1433 Vtooltalk_pattern_handler_hook = Qnil;
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.
1440 Vtooltalk_unprocessed_message_hook = Qnil;
1442 Tooltalk_Message_plist_str = build_string ("Tooltalk Message plist");
1443 Tooltalk_Pattern_plist_str = build_string ("Tooltalk Pattern p plist");
1445 staticpro(&Tooltalk_Message_plist_str);
1446 staticpro(&Tooltalk_Pattern_plist_str);
1448 #define MAKE_CONSTANT(name) do { \
1449 defsymbol (&Q_ ## name, #name); \
1450 Fset (Q_ ## name, make_int (name)); \
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);
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);
1465 MAKE_CONSTANT (TT_CLASS_UNDEFINED);
1466 MAKE_CONSTANT (TT_NOTICE);
1467 MAKE_CONSTANT (TT_REQUEST);
1468 MAKE_CONSTANT (TT_CLASS_LAST);
1470 MAKE_CONSTANT (TT_CATEGORY_UNDEFINED);
1471 MAKE_CONSTANT (TT_OBSERVE);
1472 MAKE_CONSTANT (TT_HANDLE);
1473 MAKE_CONSTANT (TT_CATEGORY_LAST);
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);
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);
1490 MAKE_CONSTANT (TT_DISCARD);
1491 MAKE_CONSTANT (TT_QUEUE);
1492 MAKE_CONSTANT (TT_START);
1494 #undef MAKE_CONSTANT
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);