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.wing@eng.sun.com>. */
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, void (*markobj) (Lisp_Object))
156 markobj (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, void (*markobj) (Lisp_Object))
230 markobj (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 */
1259 retval = tt_open ();
1260 if (tt_ptr_error (retval) != TT_OK)
1263 Vtooltalk_fd = make_int (tt_fd ());
1265 tt_session_join (tt_default_session ());
1267 lp = connect_to_file_descriptor (build_string ("tooltalk"), Qnil,
1268 Vtooltalk_fd, Vtooltalk_fd);
1271 /* Don't ask the user for confirmation when exiting Emacs */
1272 Fprocess_kill_without_query (lp, Qnil);
1273 XSETSUBR (fil, &SFreceive_tooltalk_message);
1274 set_process_filter (lp, fil, 1);
1279 Vtooltalk_fd = Qnil;
1283 #if defined (SOLARIS2)
1284 /* Apparently the tt_message_send_on_exit() function does not exist
1285 under SunOS 4.x or IRIX 5 or various other non-Solaris-2 systems.
1286 No big deal if we don't do the following under those systems. */
1288 Tt_message exit_msg = tt_message_create ();
1290 tt_message_op_set (exit_msg, "emacs-aborted");
1291 tt_message_scope_set (exit_msg, TT_SESSION);
1292 tt_message_class_set (exit_msg, TT_NOTICE);
1293 tt_message_send_on_exit (exit_msg);
1294 tt_message_destroy (exit_msg);
1299 DEFUN ("tooltalk-open-connection", Ftooltalk_open_connection, 0, 0, 0, /*
1300 Opens a connection to the ToolTalk server.
1301 Returns t if successful, nil otherwise.
1305 if (!NILP (Vtooltalk_fd))
1306 error ("Already connected to ToolTalk.");
1308 error ("Can't connect to ToolTalk in batch mode.");
1310 return NILP (Vtooltalk_fd) ? Qnil : Qt;
1315 syms_of_tooltalk (void)
1317 defsymbol (&Qtooltalk_messagep, "tooltalk-message-p");
1318 DEFSUBR (Ftooltalk_message_p);
1319 defsymbol (&Qtooltalk_patternp, "tooltalk-pattern-p");
1320 DEFSUBR (Ftooltalk_pattern_p);
1321 defsymbol (&Qtooltalk_message_handler_hook, "tooltalk-message-handler-hook");
1322 defsymbol (&Qtooltalk_pattern_handler_hook, "tooltalk-pattern-handler-hook");
1323 defsymbol (&Qtooltalk_unprocessed_message_hook,
1324 "tooltalk-unprocessed-message-hook");
1326 DEFSUBR (Freceive_tooltalk_message);
1327 DEFSUBR (Fcreate_tooltalk_message);
1328 DEFSUBR (Fdestroy_tooltalk_message);
1329 DEFSUBR (Fadd_tooltalk_message_arg);
1330 DEFSUBR (Fget_tooltalk_message_attribute);
1331 DEFSUBR (Fset_tooltalk_message_attribute);
1332 DEFSUBR (Fsend_tooltalk_message);
1333 DEFSUBR (Freturn_tooltalk_message);
1334 DEFSUBR (Fcreate_tooltalk_pattern);
1335 DEFSUBR (Fdestroy_tooltalk_pattern);
1336 DEFSUBR (Fadd_tooltalk_pattern_attribute);
1337 DEFSUBR (Fadd_tooltalk_pattern_arg);
1338 DEFSUBR (Fregister_tooltalk_pattern);
1339 DEFSUBR (Funregister_tooltalk_pattern);
1340 DEFSUBR (Ftooltalk_pattern_plist_get);
1341 DEFSUBR (Ftooltalk_pattern_prop_set);
1342 DEFSUBR (Ftooltalk_pattern_prop_get);
1343 DEFSUBR (Ftooltalk_default_procid);
1344 DEFSUBR (Ftooltalk_default_session);
1345 DEFSUBR (Ftooltalk_open_connection);
1347 defsymbol (&Qreceive_tooltalk_message, "receive-tooltalk-message");
1348 defsymbol (&Qtt_address, "address");
1349 defsymbol (&Qtt_args_count, "args_count");
1350 defsymbol (&Qtt_arg_bval, "arg_bval");
1351 defsymbol (&Qtt_arg_ival, "arg_ival");
1352 defsymbol (&Qtt_arg_mode, "arg_mode");
1353 defsymbol (&Qtt_arg_type, "arg_type");
1354 defsymbol (&Qtt_arg_val, "arg_val");
1355 defsymbol (&Qtt_class, "class");
1356 defsymbol (&Qtt_category, "category");
1357 defsymbol (&Qtt_disposition, "disposition");
1358 defsymbol (&Qtt_file, "file");
1359 defsymbol (&Qtt_gid, "gid");
1360 defsymbol (&Qtt_handler, "handler");
1361 defsymbol (&Qtt_handler_ptype, "handler_ptype");
1362 defsymbol (&Qtt_object, "object");
1363 defsymbol (&Qtt_op, "op");
1364 defsymbol (&Qtt_opnum, "opnum");
1365 defsymbol (&Qtt_otype, "otype");
1366 defsymbol (&Qtt_scope, "scope");
1367 defsymbol (&Qtt_sender, "sender");
1368 defsymbol (&Qtt_sender_ptype, "sender_ptype");
1369 defsymbol (&Qtt_session, "session");
1370 defsymbol (&Qtt_state, "state");
1371 defsymbol (&Qtt_status, "status");
1372 defsymbol (&Qtt_status_string, "status_string");
1373 defsymbol (&Qtt_uid, "uid");
1374 defsymbol (&Qtt_callback, "callback");
1375 defsymbol (&Qtt_prop, "prop");
1376 defsymbol (&Qtt_plist, "plist");
1377 defsymbol (&Qtt_reject, "reject");
1378 defsymbol (&Qtt_reply, "reply");
1379 defsymbol (&Qtt_fail, "fail");
1381 deferror (&Qtooltalk_error, "tooltalk-error", "ToolTalk error", Qio_error);
1385 vars_of_tooltalk (void)
1387 Fprovide (intern ("tooltalk"));
1389 DEFVAR_LISP ("tooltalk-fd", &Vtooltalk_fd /*
1390 File descriptor returned by tt_initialize; nil if not connected to ToolTalk.
1392 Vtooltalk_fd = Qnil;
1394 DEFVAR_LISP ("tooltalk-message-handler-hook",
1395 &Vtooltalk_message_handler_hook /*
1396 List of functions to be applied to each ToolTalk message reply received.
1397 This will always occur as a result of our sending a request message.
1398 Functions will be called with two arguments, the message and the
1399 corresponding pattern. This hook will not be called if the request
1400 message was created without a C-level callback function (see
1401 `tooltalk-unprocessed-message-hook').
1403 Vtooltalk_message_handler_hook = Qnil;
1405 DEFVAR_LISP ("tooltalk-pattern-handler-hook",
1406 &Vtooltalk_pattern_handler_hook /*
1407 List of functions to be applied to each pattern-matching ToolTalk message.
1408 This is all messages except those handled by `tooltalk-message-handler-hook'.
1409 Functions will be called with two arguments, the message and the
1410 corresponding pattern.
1412 Vtooltalk_pattern_handler_hook = Qnil;
1414 DEFVAR_LISP ("tooltalk-unprocessed-message-hook",
1415 &Vtooltalk_unprocessed_message_hook /*
1416 List of functions to be applied to each unprocessed ToolTalk message.
1417 Unprocessed messages are messages that didn't match any patterns.
1419 Vtooltalk_unprocessed_message_hook = Qnil;
1421 Tooltalk_Message_plist_str = build_string ("Tooltalk Message plist");
1422 Tooltalk_Pattern_plist_str = build_string ("Tooltalk Pattern p plist");
1424 staticpro(&Tooltalk_Message_plist_str);
1425 staticpro(&Tooltalk_Pattern_plist_str);
1427 #define MAKE_CONSTANT(name) do { \
1428 defsymbol (&Q_ ## name, #name); \
1429 Fset (Q_ ## name, make_int (name)); \
1432 MAKE_CONSTANT (TT_MODE_UNDEFINED);
1433 MAKE_CONSTANT (TT_IN);
1434 MAKE_CONSTANT (TT_OUT);
1435 MAKE_CONSTANT (TT_INOUT);
1436 MAKE_CONSTANT (TT_MODE_LAST);
1438 MAKE_CONSTANT (TT_SCOPE_NONE);
1439 MAKE_CONSTANT (TT_SESSION);
1440 MAKE_CONSTANT (TT_FILE);
1441 MAKE_CONSTANT (TT_BOTH);
1442 MAKE_CONSTANT (TT_FILE_IN_SESSION);
1444 MAKE_CONSTANT (TT_CLASS_UNDEFINED);
1445 MAKE_CONSTANT (TT_NOTICE);
1446 MAKE_CONSTANT (TT_REQUEST);
1447 MAKE_CONSTANT (TT_CLASS_LAST);
1449 MAKE_CONSTANT (TT_CATEGORY_UNDEFINED);
1450 MAKE_CONSTANT (TT_OBSERVE);
1451 MAKE_CONSTANT (TT_HANDLE);
1452 MAKE_CONSTANT (TT_CATEGORY_LAST);
1454 MAKE_CONSTANT (TT_PROCEDURE);
1455 MAKE_CONSTANT (TT_OBJECT);
1456 MAKE_CONSTANT (TT_HANDLER);
1457 MAKE_CONSTANT (TT_OTYPE);
1458 MAKE_CONSTANT (TT_ADDRESS_LAST);
1460 MAKE_CONSTANT (TT_CREATED);
1461 MAKE_CONSTANT (TT_SENT);
1462 MAKE_CONSTANT (TT_HANDLED);
1463 MAKE_CONSTANT (TT_FAILED);
1464 MAKE_CONSTANT (TT_QUEUED);
1465 MAKE_CONSTANT (TT_STARTED);
1466 MAKE_CONSTANT (TT_REJECTED);
1467 MAKE_CONSTANT (TT_STATE_LAST);
1469 MAKE_CONSTANT (TT_DISCARD);
1470 MAKE_CONSTANT (TT_QUEUE);
1471 MAKE_CONSTANT (TT_START);
1473 #undef MAKE_CONSTANT
1475 staticpro (&Vtooltalk_message_gcpro);
1476 staticpro (&Vtooltalk_pattern_gcpro);
1477 Vtooltalk_message_gcpro =
1478 make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
1479 Vtooltalk_pattern_gcpro =
1480 make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);