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 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 Lisp_Tooltalk_Message);
182 make_tooltalk_message (Tt_message m)
185 Lisp_Tooltalk_Message *msg =
186 alloc_lcrecord_type (Lisp_Tooltalk_Message, &lrecord_tooltalk_message);
189 msg->callback = Qnil;
190 msg->plist_sym = Fmake_symbol (Tooltalk_Message_plist_str);
191 XSETTOOLTALK_MESSAGE (val, msg);
196 unbox_tooltalk_message (Lisp_Object msg)
198 CHECK_TOOLTALK_MESSAGE (msg);
199 return XTOOLTALK_MESSAGE (msg)->m;
202 DEFUN ("tooltalk-message-p", Ftooltalk_message_p, 1, 1, 0, /*
203 Return non-nil if OBJECT is a tooltalk message.
207 return TOOLTALK_MESSAGEP (object) ? Qt : Qnil;
214 /* machinery for tooltalk-pattern type */
217 Lisp_Object Qtooltalk_patternp;
219 struct Lisp_Tooltalk_Pattern
221 struct lcrecord_header header;
222 Lisp_Object plist_sym, callback;
227 mark_tooltalk_pattern (Lisp_Object obj)
229 mark_object (XTOOLTALK_PATTERN (obj)->callback);
230 return XTOOLTALK_PATTERN (obj)->plist_sym;
234 print_tooltalk_pattern (Lisp_Object obj, Lisp_Object printcharfun,
237 Lisp_Tooltalk_Pattern *p = XTOOLTALK_PATTERN (obj);
242 error ("printing unreadable object #<tooltalk_pattern 0x%x>",
245 sprintf (buf, "#<tooltalk_pattern id:0x%lx 0x%x>", (long) (p->p), p->header.uid);
246 write_c_string (buf, printcharfun);
249 DEFINE_LRECORD_IMPLEMENTATION ("tooltalk-pattern", tooltalk_pattern,
250 mark_tooltalk_pattern, print_tooltalk_pattern,
252 Lisp_Tooltalk_Pattern);
255 make_tooltalk_pattern (Tt_pattern p)
257 Lisp_Tooltalk_Pattern *pat =
258 alloc_lcrecord_type (Lisp_Tooltalk_Pattern, &lrecord_tooltalk_pattern);
262 pat->callback = Qnil;
263 pat->plist_sym = Fmake_symbol (Tooltalk_Pattern_plist_str);
265 XSETTOOLTALK_PATTERN (val, pat);
270 unbox_tooltalk_pattern (Lisp_Object pattern)
272 CHECK_TOOLTALK_PATTERN (pattern);
273 return XTOOLTALK_PATTERN (pattern)->p;
276 DEFUN ("tooltalk-pattern-p", Ftooltalk_pattern_p, 1, 1, 0, /*
277 Return non-nil if OBJECT is a tooltalk pattern.
281 return TOOLTALK_PATTERNP (object) ? Qt : Qnil;
288 tooltalk_constant_value (Lisp_Object s)
292 else if (SYMBOLP (s))
293 return XINT (XSYMBOL (s)->value);
295 return 0; /* should never occur */
299 check_status (Tt_status st)
302 signal_error (Qtooltalk_error,
303 Fcons (build_string (tt_status_message (st)), Qnil));
306 DEFUN ("receive-tooltalk-message", Freceive_tooltalk_message, 0, 2, 0, /*
307 Run tt_message_receive().
308 This function is the process handler for the ToolTalk connection process.
312 /* This function can GC */
313 Tt_message mess = tt_message_receive ();
314 Lisp_Object message_ = make_tooltalk_message (mess);
318 if (mess != NULL && !NILP (Vtooltalk_unprocessed_message_hook))
319 va_run_hook_with_args (Qtooltalk_unprocessed_message_hook, 1, message_);
322 /* see comment in event-stream.c about this return value. */
326 static Tt_callback_action
327 tooltalk_message_callback (Tt_message m, Tt_pattern p)
329 /* This function can GC */
331 Lisp_Object message_;
333 struct gcpro gcpro1, gcpro2;
338 fprintf (tooltalk_log_file, "message_cb: %d\n", m);
339 fprintf (tooltalk_log_file, "op: %s (", tt_message_op (m));
340 for (j = tt_message_args_count (m), i = 0; i < j; i++) {
341 fprintf (tooltalk_log_file, "%s \"%s\"", tt_message_arg_type (m, i),
342 tt_message_arg_val (m, i));
343 fprintf (tooltalk_log_file, "%s", i == j-1 ? ")" : ", ");
345 fprintf (tooltalk_log_file, "\n\n");
346 fflush (tooltalk_log_file);
349 VOID_TO_LISP (message_, tt_message_user (m, TOOLTALK_MESSAGE_KEY));
350 pattern = make_tooltalk_pattern (p);
351 cb = XTOOLTALK_MESSAGE (message_)->callback;
352 GCPRO2 (message_, pattern);
353 if (!NILP (Vtooltalk_message_handler_hook))
354 va_run_hook_with_args (Qtooltalk_message_handler_hook, 2,
357 if ((SYMBOLP (cb) && EQ (Qt, Ffboundp (cb))) ||
358 (CONSP (cb) && EQ (Qlambda, Fcar (cb)) &&
359 !NILP (Flistp (Fcar (Fcdr (cb))))))
360 call2 (cb, message_, pattern);
363 tt_message_destroy (m);
364 Fremhash (message_, Vtooltalk_message_gcpro);
366 return TT_CALLBACK_PROCESSED;
369 static Tt_callback_action
370 tooltalk_pattern_callback (Tt_message m, Tt_pattern p)
372 /* This function can GC */
374 Lisp_Object message_;
376 struct gcpro gcpro1, gcpro2;
381 fprintf (tooltalk_log_file, "pattern_cb: %d\n", m);
382 fprintf (tooltalk_log_file, "op: %s (", tt_message_op (m));
383 for (j = tt_message_args_count (m), i = 0; i < j; i++) {
384 fprintf (tooltalk_log_file, "%s \"%s\"", tt_message_arg_type (m, i),
385 tt_message_arg_val (m, i));
386 fprintf (tooltalk_log_file, "%s", i == j-1 ? ")" : ", ");
388 fprintf (tooltalk_log_file, "\n\n");
389 fflush (tooltalk_log_file);
392 message_ = make_tooltalk_message (m);
393 VOID_TO_LISP (pattern, tt_pattern_user (p, TOOLTALK_PATTERN_KEY));
394 cb = XTOOLTALK_PATTERN (pattern)->callback;
395 GCPRO2 (message_, pattern);
396 if (!NILP (Vtooltalk_pattern_handler_hook))
397 va_run_hook_with_args (Qtooltalk_pattern_handler_hook, 2,
400 if (SYMBOLP (cb) && EQ (Qt, Ffboundp (cb)))
401 call2 (cb, message_, pattern);
404 tt_message_destroy (m);
405 return TT_CALLBACK_PROCESSED;
409 tt_mode_symbol (Tt_mode n)
413 case TT_MODE_UNDEFINED: return Q_TT_MODE_UNDEFINED;
414 case TT_IN: return Q_TT_IN;
415 case TT_OUT: return Q_TT_OUT;
416 case TT_INOUT: return Q_TT_INOUT;
417 case TT_MODE_LAST: return Q_TT_MODE_LAST;
418 default: return Qnil;
423 tt_scope_symbol (Tt_scope n)
427 case TT_SCOPE_NONE: return Q_TT_SCOPE_NONE;
428 case TT_SESSION: return Q_TT_SESSION;
429 case TT_FILE: return Q_TT_FILE;
430 case TT_BOTH: return Q_TT_BOTH;
431 case TT_FILE_IN_SESSION: return Q_TT_FILE_IN_SESSION;
432 default: return Qnil;
438 tt_class_symbol (Tt_class n)
442 case TT_CLASS_UNDEFINED: return Q_TT_CLASS_UNDEFINED;
443 case TT_NOTICE: return Q_TT_NOTICE;
444 case TT_REQUEST: return Q_TT_REQUEST;
445 case TT_CLASS_LAST: return Q_TT_CLASS_LAST;
446 default: return Qnil;
451 * This is not being used. Is that a mistake or is this function
452 * simply not necessary?
456 tt_category_symbol (Tt_category n)
460 case TT_CATEGORY_UNDEFINED: return Q_TT_CATEGORY_UNDEFINED;
461 case TT_OBSERVE: return Q_TT_OBSERVE;
462 case TT_HANDLE: return Q_TT_HANDLE;
463 case TT_CATEGORY_LAST: return Q_TT_CATEGORY_LAST;
464 default: return Qnil;
470 tt_address_symbol (Tt_address n)
474 case TT_PROCEDURE: return Q_TT_PROCEDURE;
475 case TT_OBJECT: return Q_TT_OBJECT;
476 case TT_HANDLER: return Q_TT_HANDLER;
477 case TT_OTYPE: return Q_TT_OTYPE;
478 case TT_ADDRESS_LAST: return Q_TT_ADDRESS_LAST;
479 default: return Qnil;
484 tt_state_symbol (Tt_state n)
488 case TT_CREATED: return Q_TT_CREATED;
489 case TT_SENT: return Q_TT_SENT;
490 case TT_HANDLED: return Q_TT_HANDLED;
491 case TT_FAILED: return Q_TT_FAILED;
492 case TT_QUEUED: return Q_TT_QUEUED;
493 case TT_STARTED: return Q_TT_STARTED;
494 case TT_REJECTED: return Q_TT_REJECTED;
495 case TT_STATE_LAST: return Q_TT_STATE_LAST;
496 default: return Qnil;
501 tt_build_string (char *s)
503 return build_string (s ? s : "");
507 tt_opnum_string (int n)
511 sprintf (buf, "%u", n);
512 return build_string (buf);
516 tt_message_arg_ival_string (Tt_message m, int n)
521 check_status (tt_message_arg_ival (m, n, &value));
522 long_to_string (buf, value);
523 return build_string (buf);
527 tt_message_arg_bval_vector (Tt_message m, int n)
529 /* !!#### This function has not been Mule-ized */
533 check_status (tt_message_arg_bval (m, n, &value, &len));
535 return make_string (value, len);
538 DEFUN ("get-tooltalk-message-attribute", Fget_tooltalk_message_attribute,
540 Return the indicated Tooltalk message attribute. Attributes are
541 identified by symbols with the same name (underscores and all) as the
542 suffix of the Tooltalk tt_message_<attribute> function that extracts the value.
543 String attribute values are copied, enumerated type values (except disposition)
544 are converted to symbols - e.g. TT_HANDLER is 'TT_HANDLER, uid and gid are
545 represented by fixnums (small integers), opnum is converted to a string,
546 and disposition is converted to a fixnum. We convert opnum (a C int) to a
547 string, e.g. 123 => "123" because there's no guarantee that opnums will fit
548 within the range of Lisp integers.
550 Use the 'plist attribute instead of the C API 'user attribute
551 for user defined message data. To retrieve the value of a message property
552 specify the indicator for argn. For example to get the value of a property
554 (get-tooltalk-message-attribute message 'plist 'rflag)
556 To get the value of a message argument use one of the 'arg_val (strings),
557 'arg_ival (integers), or 'arg_bval (strings with embedded nulls), attributes.
558 For example to get the integer value of the third argument:
560 (get-tooltalk-message-attribute message 'arg_ival 2)
562 As you can see, argument numbers are zero based. The type of each argument
563 can be retrieved with the 'arg_type attribute; however, Tooltalk doesn't
564 define any semantics for the string value of 'arg_type. Conventionally
565 "string" is used for strings and "int" for 32 bit integers. Note that
566 Emacs Lisp stores the lengths of strings explicitly (unlike C) so treating the
567 value returned by 'arg_bval like a string is fine.
569 (message_, attribute, argn))
571 Tt_message m = unbox_tooltalk_message (message_);
574 CHECK_SYMBOL (attribute);
575 if (EQ (attribute, (Qtt_arg_bval)) ||
576 EQ (attribute, (Qtt_arg_ival)) ||
577 EQ (attribute, (Qtt_arg_mode)) ||
578 EQ (attribute, (Qtt_arg_type)) ||
579 EQ (attribute, (Qtt_arg_val)))
585 if (!VALID_TOOLTALK_MESSAGEP (m))
588 else if (EQ (attribute, Qtt_arg_bval))
589 return tt_message_arg_bval_vector (m, n);
591 else if (EQ (attribute, Qtt_arg_ival))
592 return tt_message_arg_ival_string (m, n);
594 else if (EQ (attribute, Qtt_arg_mode))
595 return tt_mode_symbol (tt_message_arg_mode (m, n));
597 else if (EQ (attribute, Qtt_arg_type))
598 return tt_build_string (tt_message_arg_type (m, n));
600 else if (EQ (attribute, Qtt_arg_val))
601 return tt_message_arg_bval_vector (m, n);
603 else if (EQ (attribute, Qtt_args_count))
604 return make_int (tt_message_args_count (m));
606 else if (EQ (attribute, Qtt_address))
607 return tt_address_symbol (tt_message_address (m));
609 else if (EQ (attribute, Qtt_class))
610 return tt_class_symbol (tt_message_class (m));
612 else if (EQ (attribute, Qtt_disposition))
613 return make_int (tt_message_disposition (m));
615 else if (EQ (attribute, Qtt_file))
616 return tt_build_string (tt_message_file (m));
618 else if (EQ (attribute, Qtt_gid))
619 return make_int (tt_message_gid (m));
621 else if (EQ (attribute, Qtt_handler))
622 return tt_build_string (tt_message_handler (m));
624 else if (EQ (attribute, Qtt_handler_ptype))
625 return tt_build_string (tt_message_handler_ptype (m));
627 else if (EQ (attribute, Qtt_object))
628 return tt_build_string (tt_message_object (m));
630 else if (EQ (attribute, Qtt_op))
631 return tt_build_string (tt_message_op (m));
633 else if (EQ (attribute, Qtt_opnum))
634 return tt_opnum_string (tt_message_opnum (m));
636 else if (EQ (attribute, Qtt_otype))
637 return tt_build_string (tt_message_otype (m));
639 else if (EQ (attribute, Qtt_scope))
640 return tt_scope_symbol (tt_message_scope (m));
642 else if (EQ (attribute, Qtt_sender))
643 return tt_build_string (tt_message_sender (m));
645 else if (EQ (attribute, Qtt_sender_ptype))
646 return tt_build_string (tt_message_sender_ptype (m));
648 else if (EQ (attribute, Qtt_session))
649 return tt_build_string (tt_message_session (m));
651 else if (EQ (attribute, Qtt_state))
652 return tt_state_symbol (tt_message_state (m));
654 else if (EQ (attribute, Qtt_status))
655 return make_int (tt_message_status (m));
657 else if (EQ (attribute, Qtt_status_string))
658 return tt_build_string (tt_message_status_string (m));
660 else if (EQ (attribute, Qtt_uid))
661 return make_int (tt_message_uid (m));
663 else if (EQ (attribute, Qtt_callback))
664 return XTOOLTALK_MESSAGE (message_)->callback;
666 else if (EQ (attribute, Qtt_prop))
667 return Fget (XTOOLTALK_MESSAGE (message_)->plist_sym, argn, Qnil);
669 else if (EQ (attribute, Qtt_plist))
670 return Fcopy_sequence (Fsymbol_plist
671 (XTOOLTALK_MESSAGE (message_)->plist_sym));
674 signal_simple_error ("Invalid value for `get-tooltalk-message-attribute'",
680 DEFUN ("set-tooltalk-message-attribute", Fset_tooltalk_message_attribute,
682 Initialize one Tooltalk message attribute.
684 Attribute names and values are the same as for
685 `get-tooltalk-message-attribute'. A property list is provided for user
686 data (instead of the 'user message attribute); see
687 `get-tooltalk-message-attribute'.
689 The value of callback should be the name of a function of one argument.
690 It will be applied to the message and matching pattern each time the state of the
691 message changes. This is usually used to notice when the messages state has
692 changed to TT_HANDLED (or TT_FAILED), so that reply argument values
695 If one of the argument attributes is specified, 'arg_val, 'arg_ival, or
696 'arg_bval then argn must be the number of an already created argument.
697 New arguments can be added to a message with add-tooltalk-message-arg.
699 (value, message_, attribute, argn))
701 Tt_message m = unbox_tooltalk_message (message_);
703 Tt_status (*fun_str) (Tt_message, const char *) = 0;
705 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 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_scope))
736 CHECK_TOOLTALK_CONSTANT (value);
737 tt_message_scope_set (m, (Tt_scope) tooltalk_constant_value (value));
739 else if (EQ (attribute, Qtt_file))
740 fun_str = tt_message_file_set;
741 else if (EQ (attribute, Qtt_handler_ptype))
742 fun_str = tt_message_handler_ptype_set;
743 else if (EQ (attribute, Qtt_handler))
744 fun_str = tt_message_handler_set;
745 else if (EQ (attribute, Qtt_object))
746 fun_str = tt_message_object_set;
747 else if (EQ (attribute, Qtt_op))
748 fun_str = tt_message_op_set;
749 else if (EQ (attribute, Qtt_otype))
750 fun_str = tt_message_otype_set;
751 else if (EQ (attribute, Qtt_sender_ptype))
752 fun_str = tt_message_sender_ptype_set;
753 else if (EQ (attribute, Qtt_session))
754 fun_str = tt_message_session_set;
755 else if (EQ (attribute, Qtt_status_string))
756 fun_str = tt_message_status_string_set;
757 else if (EQ (attribute, Qtt_arg_bval))
760 Extcount value_ext_len;
761 CHECK_STRING (value);
762 TO_EXTERNAL_FORMAT (LISP_STRING, value,
763 ALLOCA, (value_ext, value_ext_len),
765 tt_message_arg_bval_set (m, n, value_ext, value_ext_len);
767 else if (EQ (attribute, Qtt_arg_ival))
770 tt_message_arg_ival_set (m, n, XINT (value));
772 else if (EQ (attribute, Qtt_arg_val))
774 const char *value_ext;
775 CHECK_STRING (value);
776 TO_EXTERNAL_FORMAT (LISP_STRING, value, C_STRING_ALLOCA, value_ext, Qnative);
777 tt_message_arg_val_set (m, n, value_ext);
779 else if (EQ (attribute, Qtt_status))
782 tt_message_status_set (m, XINT (value));
784 else if (EQ (attribute, Qtt_callback))
786 CHECK_SYMBOL (value);
787 XTOOLTALK_MESSAGE (message_)->callback = value;
789 else if (EQ (attribute, Qtt_prop))
791 return Fput (XTOOLTALK_MESSAGE (message_)->plist_sym, argn, value);
794 signal_simple_error ("Invalid value for `set-tooltalk-message-attribute'",
799 const char *value_ext;
800 CHECK_STRING (value);
801 TO_EXTERNAL_FORMAT (LISP_STRING, value, C_STRING_ALLOCA, value_ext, Qnative);
802 (*fun_str) (m, value_ext);
808 DEFUN ("return-tooltalk-message", Freturn_tooltalk_message, 1, 2, 0, /*
809 Send a reply to this message. The second argument can be
810 'reply, 'reject or 'fail; the default is 'reply. Before sending
811 a reply all message arguments whose mode is TT_INOUT or TT_OUT should
812 have been filled in - see set-tooltalk-message-attribute.
816 Tt_message m = unbox_tooltalk_message (message_);
823 if (!VALID_TOOLTALK_MESSAGEP (m))
825 else if (EQ (mode, Qtt_reply))
826 tt_message_reply (m);
827 else if (EQ (mode, Qtt_reject))
828 tt_message_reject (m);
829 else if (EQ (mode, Qtt_fail))
835 DEFUN ("create-tooltalk-message", Fcreate_tooltalk_message, 0, 1, 0, /*
836 Create a new tooltalk message.
837 The messages session attribute is initialized to the default session.
838 Other attributes can be initialized with `set-tooltalk-message-attribute'.
839 `make-tooltalk-message' is the preferred to create and initialize a message.
841 Optional arg NO-CALLBACK says don't add a C-level callback at all.
842 Normally don't do that; just don't specify the Lisp callback when
843 calling `make-tooltalk-message'.
847 Tt_message m = tt_message_create ();
848 Lisp_Object message_ = make_tooltalk_message (m);
849 if (NILP (no_callback))
851 tt_message_callback_add (m, tooltalk_message_callback);
853 tt_message_session_set (m, tt_default_session ());
854 tt_message_user_set (m, TOOLTALK_MESSAGE_KEY, LISP_TO_VOID (message_));
858 DEFUN ("destroy-tooltalk-message", Fdestroy_tooltalk_message, 1, 1, 0, /*
859 Apply tt_message_destroy() to the message.
860 It's not necessary to destroy messages after they've been processed by
861 a message or pattern callback; the Lisp/Tooltalk callback machinery does
866 Tt_message m = unbox_tooltalk_message (message_);
868 if (VALID_TOOLTALK_MESSAGEP (m))
869 /* #### Should we call Fremhash() here? It seems that
872 (send-tooltalk-message)
873 (destroy-tooltalk-message)
875 which would imply that destroying a sent ToolTalk message
876 doesn't actually destroy it; when a response is sent back,
877 the callback for the message will still be called.
879 But then maybe not: Maybe it really does destroy it,
880 and the reason for that paradigm is that the author
881 of `send-tooltalk-message' didn't really know what he
882 was talking about when he said that it's a good idea
883 to call `destroy-tooltalk-message' after sending it. */
884 tt_message_destroy (m);
890 DEFUN ("add-tooltalk-message-arg", Fadd_tooltalk_message_arg, 3, 4, 0, /*
891 Append one new argument to the message.
892 MODE must be one of TT_IN, TT_INOUT, or TT_OUT; VTYPE must be a string;
893 and VALUE can be a string or an integer. Tooltalk doesn't
894 define any semantics for VTYPE, so only the participants in the
895 protocol you're using need to agree what types mean (if anything).
896 Conventionally "string" is used for strings and "int" for 32 bit integers.
897 Arguments can initialized by providing a value or with
898 `set-tooltalk-message-attribute'. The latter is necessary if you
899 want to initialize the argument with a string that can contain
900 embedded nulls (use 'arg_bval).
902 (message_, mode, vtype, value))
904 Tt_message m = unbox_tooltalk_message (message_);
907 CHECK_STRING (vtype);
908 CHECK_TOOLTALK_CONSTANT (mode);
910 n = (Tt_mode) tooltalk_constant_value (mode);
912 if (!VALID_TOOLTALK_MESSAGEP (m))
915 const char *vtype_ext;
917 TO_EXTERNAL_FORMAT (LISP_STRING, vtype, C_STRING_ALLOCA, vtype_ext, Qnative);
919 tt_message_arg_add (m, n, vtype_ext, NULL);
920 else if (STRINGP (value))
922 const char *value_ext;
923 TO_EXTERNAL_FORMAT (LISP_STRING, value, C_STRING_ALLOCA, value_ext, Qnative);
924 tt_message_arg_add (m, n, vtype_ext, value_ext);
926 else if (INTP (value))
927 tt_message_iarg_add (m, n, vtype_ext, XINT (value));
933 DEFUN ("send-tooltalk-message", Fsend_tooltalk_message, 1, 1, 0, /*
934 Send the message on its way.
935 Once the message has been sent it's almost always a good idea to get rid of
936 it with `destroy-tooltalk-message'.
940 Tt_message m = unbox_tooltalk_message (message_);
942 if (VALID_TOOLTALK_MESSAGEP (m))
945 Fputhash (message_, Qnil, Vtooltalk_message_gcpro);
951 DEFUN ("create-tooltalk-pattern", Fcreate_tooltalk_pattern, 0, 0, 0, /*
952 Create a new Tooltalk pattern.
953 Its session attribute is initialized to be the default session.
957 Tt_pattern p = tt_pattern_create ();
958 Lisp_Object pattern = make_tooltalk_pattern (p);
960 tt_pattern_callback_add (p, tooltalk_pattern_callback);
961 tt_pattern_session_add (p, tt_default_session ());
962 tt_pattern_user_set (p, TOOLTALK_PATTERN_KEY, LISP_TO_VOID (pattern));
968 DEFUN ("destroy-tooltalk-pattern", Fdestroy_tooltalk_pattern, 1, 1, 0, /*
969 Apply tt_pattern_destroy() to the pattern.
970 This effectively unregisters the pattern.
974 Tt_pattern p = unbox_tooltalk_pattern (pattern);
976 if (VALID_TOOLTALK_PATTERNP (p))
978 tt_pattern_destroy (p);
979 Fremhash (pattern, Vtooltalk_pattern_gcpro);
986 DEFUN ("add-tooltalk-pattern-attribute", Fadd_tooltalk_pattern_attribute, 3, 3, 0, /*
987 Add one value to the indicated pattern attribute.
988 All Tooltalk pattern attributes are supported except 'user. The names
989 of attributes are the same as the Tooltalk accessors used to set them
990 less the "tooltalk_pattern_" prefix and the "_add" ...
992 (value, pattern, attribute))
994 Tt_pattern p = unbox_tooltalk_pattern (pattern);
996 CHECK_SYMBOL (attribute);
998 if (!VALID_TOOLTALK_PATTERNP (p))
1001 else if (EQ (attribute, Qtt_category))
1003 CHECK_TOOLTALK_CONSTANT (value);
1004 tt_pattern_category_set (p, ((Tt_category)
1005 tooltalk_constant_value (value)));
1007 else if (EQ (attribute, Qtt_address))
1009 CHECK_TOOLTALK_CONSTANT (value);
1010 tt_pattern_address_add (p, ((Tt_address)
1011 tooltalk_constant_value (value)));
1013 else if (EQ (attribute, Qtt_class))
1015 CHECK_TOOLTALK_CONSTANT (value);
1016 tt_pattern_class_add (p, (Tt_class) tooltalk_constant_value (value));
1018 else if (EQ (attribute, Qtt_disposition))
1020 CHECK_TOOLTALK_CONSTANT (value);
1021 tt_pattern_disposition_add (p, ((Tt_disposition)
1022 tooltalk_constant_value (value)));
1024 else if (EQ (attribute, Qtt_file))
1026 const char *value_ext;
1027 CHECK_STRING (value);
1028 TO_EXTERNAL_FORMAT (LISP_STRING, value, C_STRING_ALLOCA, value_ext, Qnative);
1029 tt_pattern_file_add (p, value_ext);
1031 else if (EQ (attribute, Qtt_object))
1033 const char *value_ext;
1034 CHECK_STRING (value);
1035 TO_EXTERNAL_FORMAT (LISP_STRING, value, C_STRING_ALLOCA, value_ext, Qnative);
1036 tt_pattern_object_add (p, value_ext);
1038 else if (EQ (attribute, Qtt_op))
1040 const char *value_ext;
1041 CHECK_STRING (value);
1042 TO_EXTERNAL_FORMAT (LISP_STRING, value, C_STRING_ALLOCA, value_ext, Qnative);
1043 tt_pattern_op_add (p, value_ext);
1045 else if (EQ (attribute, Qtt_otype))
1047 const char *value_ext;
1048 CHECK_STRING (value);
1049 TO_EXTERNAL_FORMAT (LISP_STRING, value, C_STRING_ALLOCA, value_ext, Qnative);
1050 tt_pattern_otype_add (p, value_ext);
1052 else if (EQ (attribute, Qtt_scope))
1054 CHECK_TOOLTALK_CONSTANT (value);
1055 tt_pattern_scope_add (p, (Tt_scope) tooltalk_constant_value (value));
1057 else if (EQ (attribute, Qtt_sender))
1059 const char *value_ext;
1060 CHECK_STRING (value);
1061 TO_EXTERNAL_FORMAT (LISP_STRING, value, C_STRING_ALLOCA, value_ext, Qnative);
1062 tt_pattern_sender_add (p, value_ext);
1064 else if (EQ (attribute, Qtt_sender_ptype))
1066 const char *value_ext;
1067 CHECK_STRING (value);
1068 TO_EXTERNAL_FORMAT (LISP_STRING, value, C_STRING_ALLOCA, value_ext, Qnative);
1069 tt_pattern_sender_ptype_add (p, value_ext);
1071 else if (EQ (attribute, Qtt_session))
1073 const char *value_ext;
1074 CHECK_STRING (value);
1075 TO_EXTERNAL_FORMAT (LISP_STRING, value, C_STRING_ALLOCA, value_ext, Qnative);
1076 tt_pattern_session_add (p, value_ext);
1078 else if (EQ (attribute, Qtt_state))
1080 CHECK_TOOLTALK_CONSTANT (value);
1081 tt_pattern_state_add (p, (Tt_state) tooltalk_constant_value (value));
1083 else if (EQ (attribute, Qtt_callback))
1085 CHECK_SYMBOL (value);
1086 XTOOLTALK_PATTERN (pattern)->callback = value;
1093 DEFUN ("add-tooltalk-pattern-arg", Fadd_tooltalk_pattern_arg, 3, 4, 0, /*
1094 Add one fully specified argument to a tooltalk pattern.
1095 Mode must be one of TT_IN, TT_INOUT, or TT_OUT, type must be a string.
1096 Value can be an integer, string or nil. If value is an integer then
1097 an integer argument (tt_pattern_iarg_add) added otherwise a string argument
1098 is added. At present there's no way to add a binary data argument.
1100 (pattern, mode, vtype, value))
1102 Tt_pattern p = unbox_tooltalk_pattern (pattern);
1105 CHECK_STRING (vtype);
1106 CHECK_TOOLTALK_CONSTANT (mode);
1108 n = (Tt_mode) tooltalk_constant_value (mode);
1110 if (!VALID_TOOLTALK_PATTERNP (p))
1114 const char *vtype_ext;
1116 TO_EXTERNAL_FORMAT (LISP_STRING, vtype, C_STRING_ALLOCA, vtype_ext, Qnative);
1118 tt_pattern_arg_add (p, n, vtype_ext, NULL);
1119 else if (STRINGP (value))
1121 const char *value_ext;
1122 TO_EXTERNAL_FORMAT (LISP_STRING, value, C_STRING_ALLOCA, value_ext, Qnative);
1123 tt_pattern_arg_add (p, n, vtype_ext, value_ext);
1125 else if (INTP (value))
1126 tt_pattern_iarg_add (p, n, vtype_ext, XINT (value));
1133 DEFUN ("register-tooltalk-pattern", Fregister_tooltalk_pattern, 1, 1, 0, /*
1134 Emacs will begin receiving messages that match this pattern.
1138 Tt_pattern p = unbox_tooltalk_pattern (pattern);
1140 if (VALID_TOOLTALK_PATTERNP (p) && tt_pattern_register (p) == TT_OK)
1142 Fputhash (pattern, Qnil, Vtooltalk_pattern_gcpro);
1150 DEFUN ("unregister-tooltalk-pattern", Funregister_tooltalk_pattern, 1, 1, 0, /*
1151 Emacs will stop receiving messages that match this pattern.
1155 Tt_pattern p = unbox_tooltalk_pattern (pattern);
1157 if (VALID_TOOLTALK_PATTERNP (p))
1159 tt_pattern_unregister (p);
1160 Fremhash (pattern, Vtooltalk_pattern_gcpro);
1167 DEFUN ("tooltalk-pattern-prop-get", Ftooltalk_pattern_prop_get, 2, 2, 0, /*
1168 Return the value of PROPERTY in tooltalk pattern PATTERN.
1169 This is the last value set with `tooltalk-pattern-prop-set'.
1171 (pattern, property))
1173 CHECK_TOOLTALK_PATTERN (pattern);
1174 return Fget (XTOOLTALK_PATTERN (pattern)->plist_sym, property, Qnil);
1178 DEFUN ("tooltalk-pattern-prop-set", Ftooltalk_pattern_prop_set, 3, 3, 0, /*
1179 Set the value of PROPERTY to VALUE in tooltalk pattern PATTERN.
1180 It can be retrieved with `tooltalk-pattern-prop-get'.
1182 (pattern, property, value))
1184 CHECK_TOOLTALK_PATTERN (pattern);
1185 return Fput (XTOOLTALK_PATTERN (pattern)->plist_sym, property, value);
1189 DEFUN ("tooltalk-pattern-plist-get", Ftooltalk_pattern_plist_get, 1, 1, 0, /*
1190 Return the a list of all the properties currently set in PATTERN.
1194 CHECK_TOOLTALK_PATTERN (pattern);
1196 Fcopy_sequence (Fsymbol_plist (XTOOLTALK_PATTERN (pattern)->plist_sym));
1199 DEFUN ("tooltalk-default-procid", Ftooltalk_default_procid, 0, 0, 0, /*
1200 Return current default process identifier for your process.
1204 char *procid = tt_default_procid ();
1205 return procid ? build_string (procid) : Qnil;
1208 DEFUN ("tooltalk-default-session", Ftooltalk_default_session, 0, 0, 0, /*
1209 Return current default session identifier for the current default procid.
1213 char *session = tt_default_session ();
1214 return session ? build_string (session) : Qnil;
1218 init_tooltalk (void)
1220 /* This function can GC */
1226 /* tt_open() messes with our signal handler flags (at least when no
1227 ttsessions is running on the machine), therefore we save the
1228 actions and restore them after the call */
1229 #ifdef HAVE_SIGPROCMASK
1231 struct sigaction ActSIGQUIT;
1232 struct sigaction ActSIGINT;
1233 struct sigaction ActSIGCHLD;
1234 sigaction (SIGQUIT, NULL, &ActSIGQUIT);
1235 sigaction (SIGINT, NULL, &ActSIGINT);
1236 sigaction (SIGCHLD, NULL, &ActSIGCHLD);
1238 retval = tt_open ();
1239 #ifdef HAVE_SIGPROCMASK
1240 sigaction (SIGQUIT, &ActSIGQUIT, NULL);
1241 sigaction (SIGINT, &ActSIGINT, NULL);
1242 sigaction (SIGCHLD, &ActSIGCHLD, NULL);
1247 if (tt_ptr_error (retval) != TT_OK)
1250 Vtooltalk_fd = make_int (tt_fd ());
1252 tt_session_join (tt_default_session ());
1254 lp = connect_to_file_descriptor (build_string ("tooltalk"), Qnil,
1255 Vtooltalk_fd, Vtooltalk_fd);
1258 /* Don't ask the user for confirmation when exiting Emacs */
1259 Fprocess_kill_without_query (lp, Qnil);
1260 XSETSUBR (fil, &SFreceive_tooltalk_message);
1261 set_process_filter (lp, fil, 1);
1266 Vtooltalk_fd = Qnil;
1270 #if defined (SOLARIS2)
1271 /* Apparently the tt_message_send_on_exit() function does not exist
1272 under SunOS 4.x or IRIX 5 or various other non-Solaris-2 systems.
1273 No big deal if we don't do the following under those systems. */
1275 Tt_message exit_msg = tt_message_create ();
1277 tt_message_op_set (exit_msg, "emacs-aborted");
1278 tt_message_scope_set (exit_msg, TT_SESSION);
1279 tt_message_class_set (exit_msg, TT_NOTICE);
1280 tt_message_send_on_exit (exit_msg);
1281 tt_message_destroy (exit_msg);
1286 DEFUN ("tooltalk-open-connection", Ftooltalk_open_connection, 0, 0, 0, /*
1287 Opens a connection to the ToolTalk server.
1288 Returns t if successful, nil otherwise.
1292 if (!NILP (Vtooltalk_fd))
1293 error ("Already connected to ToolTalk.");
1295 error ("Can't connect to ToolTalk in batch mode.");
1297 return NILP (Vtooltalk_fd) ? Qnil : Qt;
1302 syms_of_tooltalk (void)
1304 INIT_LRECORD_IMPLEMENTATION (tooltalk_message);
1305 INIT_LRECORD_IMPLEMENTATION (tooltalk_pattern);
1307 defsymbol (&Qtooltalk_messagep, "tooltalk-message-p");
1308 DEFSUBR (Ftooltalk_message_p);
1309 defsymbol (&Qtooltalk_patternp, "tooltalk-pattern-p");
1310 DEFSUBR (Ftooltalk_pattern_p);
1311 defsymbol (&Qtooltalk_message_handler_hook, "tooltalk-message-handler-hook");
1312 defsymbol (&Qtooltalk_pattern_handler_hook, "tooltalk-pattern-handler-hook");
1313 defsymbol (&Qtooltalk_unprocessed_message_hook,
1314 "tooltalk-unprocessed-message-hook");
1316 DEFSUBR (Freceive_tooltalk_message);
1317 DEFSUBR (Fcreate_tooltalk_message);
1318 DEFSUBR (Fdestroy_tooltalk_message);
1319 DEFSUBR (Fadd_tooltalk_message_arg);
1320 DEFSUBR (Fget_tooltalk_message_attribute);
1321 DEFSUBR (Fset_tooltalk_message_attribute);
1322 DEFSUBR (Fsend_tooltalk_message);
1323 DEFSUBR (Freturn_tooltalk_message);
1324 DEFSUBR (Fcreate_tooltalk_pattern);
1325 DEFSUBR (Fdestroy_tooltalk_pattern);
1326 DEFSUBR (Fadd_tooltalk_pattern_attribute);
1327 DEFSUBR (Fadd_tooltalk_pattern_arg);
1328 DEFSUBR (Fregister_tooltalk_pattern);
1329 DEFSUBR (Funregister_tooltalk_pattern);
1330 DEFSUBR (Ftooltalk_pattern_plist_get);
1331 DEFSUBR (Ftooltalk_pattern_prop_set);
1332 DEFSUBR (Ftooltalk_pattern_prop_get);
1333 DEFSUBR (Ftooltalk_default_procid);
1334 DEFSUBR (Ftooltalk_default_session);
1335 DEFSUBR (Ftooltalk_open_connection);
1337 defsymbol (&Qreceive_tooltalk_message, "receive-tooltalk-message");
1338 defsymbol (&Qtt_address, "address");
1339 defsymbol (&Qtt_args_count, "args_count");
1340 defsymbol (&Qtt_arg_bval, "arg_bval");
1341 defsymbol (&Qtt_arg_ival, "arg_ival");
1342 defsymbol (&Qtt_arg_mode, "arg_mode");
1343 defsymbol (&Qtt_arg_type, "arg_type");
1344 defsymbol (&Qtt_arg_val, "arg_val");
1345 defsymbol (&Qtt_class, "class");
1346 defsymbol (&Qtt_category, "category");
1347 defsymbol (&Qtt_disposition, "disposition");
1348 defsymbol (&Qtt_file, "file");
1349 defsymbol (&Qtt_gid, "gid");
1350 defsymbol (&Qtt_handler, "handler");
1351 defsymbol (&Qtt_handler_ptype, "handler_ptype");
1352 defsymbol (&Qtt_object, "object");
1353 defsymbol (&Qtt_op, "op");
1354 defsymbol (&Qtt_opnum, "opnum");
1355 defsymbol (&Qtt_otype, "otype");
1356 defsymbol (&Qtt_scope, "scope");
1357 defsymbol (&Qtt_sender, "sender");
1358 defsymbol (&Qtt_sender_ptype, "sender_ptype");
1359 defsymbol (&Qtt_session, "session");
1360 defsymbol (&Qtt_state, "state");
1361 defsymbol (&Qtt_status, "status");
1362 defsymbol (&Qtt_status_string, "status_string");
1363 defsymbol (&Qtt_uid, "uid");
1364 defsymbol (&Qtt_callback, "callback");
1365 defsymbol (&Qtt_prop, "prop");
1366 defsymbol (&Qtt_plist, "plist");
1367 defsymbol (&Qtt_reject, "reject");
1368 defsymbol (&Qtt_reply, "reply");
1369 defsymbol (&Qtt_fail, "fail");
1371 deferror (&Qtooltalk_error, "tooltalk-error", "ToolTalk error", Qio_error);
1375 vars_of_tooltalk (void)
1377 Fprovide (intern ("tooltalk"));
1379 DEFVAR_LISP ("tooltalk-fd", &Vtooltalk_fd /*
1380 File descriptor returned by tt_initialize; nil if not connected to ToolTalk.
1382 Vtooltalk_fd = Qnil;
1384 DEFVAR_LISP ("tooltalk-message-handler-hook",
1385 &Vtooltalk_message_handler_hook /*
1386 List of functions to be applied to each ToolTalk message reply received.
1387 This will always occur as a result of our sending a request message.
1388 Functions will be called with two arguments, the message and the
1389 corresponding pattern. This hook will not be called if the request
1390 message was created without a C-level callback function (see
1391 `tooltalk-unprocessed-message-hook').
1393 Vtooltalk_message_handler_hook = Qnil;
1395 DEFVAR_LISP ("tooltalk-pattern-handler-hook",
1396 &Vtooltalk_pattern_handler_hook /*
1397 List of functions to be applied to each pattern-matching ToolTalk message.
1398 This is all messages except those handled by `tooltalk-message-handler-hook'.
1399 Functions will be called with two arguments, the message and the
1400 corresponding pattern.
1402 Vtooltalk_pattern_handler_hook = Qnil;
1404 DEFVAR_LISP ("tooltalk-unprocessed-message-hook",
1405 &Vtooltalk_unprocessed_message_hook /*
1406 List of functions to be applied to each unprocessed ToolTalk message.
1407 Unprocessed messages are messages that didn't match any patterns.
1409 Vtooltalk_unprocessed_message_hook = Qnil;
1411 Tooltalk_Message_plist_str = build_string ("Tooltalk Message plist");
1412 Tooltalk_Pattern_plist_str = build_string ("Tooltalk Pattern p plist");
1414 staticpro(&Tooltalk_Message_plist_str);
1415 staticpro(&Tooltalk_Pattern_plist_str);
1417 #define MAKE_CONSTANT(name) do { \
1418 defsymbol (&Q_ ## name, #name); \
1419 Fset (Q_ ## name, make_int (name)); \
1422 MAKE_CONSTANT (TT_MODE_UNDEFINED);
1423 MAKE_CONSTANT (TT_IN);
1424 MAKE_CONSTANT (TT_OUT);
1425 MAKE_CONSTANT (TT_INOUT);
1426 MAKE_CONSTANT (TT_MODE_LAST);
1428 MAKE_CONSTANT (TT_SCOPE_NONE);
1429 MAKE_CONSTANT (TT_SESSION);
1430 MAKE_CONSTANT (TT_FILE);
1431 MAKE_CONSTANT (TT_BOTH);
1432 MAKE_CONSTANT (TT_FILE_IN_SESSION);
1434 MAKE_CONSTANT (TT_CLASS_UNDEFINED);
1435 MAKE_CONSTANT (TT_NOTICE);
1436 MAKE_CONSTANT (TT_REQUEST);
1437 MAKE_CONSTANT (TT_CLASS_LAST);
1439 MAKE_CONSTANT (TT_CATEGORY_UNDEFINED);
1440 MAKE_CONSTANT (TT_OBSERVE);
1441 MAKE_CONSTANT (TT_HANDLE);
1442 MAKE_CONSTANT (TT_CATEGORY_LAST);
1444 MAKE_CONSTANT (TT_PROCEDURE);
1445 MAKE_CONSTANT (TT_OBJECT);
1446 MAKE_CONSTANT (TT_HANDLER);
1447 MAKE_CONSTANT (TT_OTYPE);
1448 MAKE_CONSTANT (TT_ADDRESS_LAST);
1450 MAKE_CONSTANT (TT_CREATED);
1451 MAKE_CONSTANT (TT_SENT);
1452 MAKE_CONSTANT (TT_HANDLED);
1453 MAKE_CONSTANT (TT_FAILED);
1454 MAKE_CONSTANT (TT_QUEUED);
1455 MAKE_CONSTANT (TT_STARTED);
1456 MAKE_CONSTANT (TT_REJECTED);
1457 MAKE_CONSTANT (TT_STATE_LAST);
1459 MAKE_CONSTANT (TT_DISCARD);
1460 MAKE_CONSTANT (TT_QUEUE);
1461 MAKE_CONSTANT (TT_START);
1463 #undef MAKE_CONSTANT
1465 staticpro (&Vtooltalk_message_gcpro);
1466 staticpro (&Vtooltalk_pattern_gcpro);
1467 Vtooltalk_message_gcpro =
1468 make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
1469 Vtooltalk_pattern_gcpro =
1470 make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);