Mercurial > hg > xemacs-beta

comparison src/tooltalk.c @ 428:3ecd8885ac67 r21-2-22

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-22
author cvs
date Mon, 13 Aug 2007 11:28:15 +0200
parents
children 8de8e3f6228a
comparison
equal deleted inserted replaced
427:0a0253eac470 428:3ecd8885ac67
1 /* Tooltalk support for Emacs.
2 Copyright (C) 1993, 1994 Sun Microsystems, Inc.
3 Copyright (C) 1995 Free Software Foundation, Inc.
4
5 This file is part of XEmacs.
6
7 XEmacs is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the
9 Free Software Foundation; either version 2, or (at your option) any
10 later version.
11
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with XEmacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
21
22 /* Synched up with: Not in FSF. */
23
24 /* Written by John Rose <john.rose@eng.sun.com>.
25 Heavily modified and cleaned up by Ben Wing <ben@xemacs.org>. */
26
27 #include <config.h>
28 #include "lisp.h"
29
30 #include <X11/Xlib.h>
31
32 #include "buffer.h"
33 #include "elhash.h"
34 #include "process.h"
35 #include "tooltalk.h"
36
37 Lisp_Object Vtooltalk_fd;
38
39 #ifdef TT_DEBUG
40 static FILE *tooltalk_log_file;
41 #endif
42
43 static Lisp_Object
44 Vtooltalk_message_handler_hook,
45 Vtooltalk_pattern_handler_hook,
46 Vtooltalk_unprocessed_message_hook;
47
48 static Lisp_Object
49 Qtooltalk_message_handler_hook,
50 Qtooltalk_pattern_handler_hook,
51 Qtooltalk_unprocessed_message_hook;
52
53 static Lisp_Object
54 Qreceive_tooltalk_message,
55 Qtt_address,
56 Qtt_args_count,
57 Qtt_arg_bval,
58 Qtt_arg_ival,
59 Qtt_arg_mode,
60 Qtt_arg_type,
61 Qtt_arg_val,
62 Qtt_class,
63 Qtt_category,
64 Qtt_disposition,
65 Qtt_file,
66 Qtt_gid,
67 Qtt_handler,
68 Qtt_handler_ptype,
69 Qtt_object,
70 Qtt_op,
71 Qtt_opnum,
72 Qtt_otype,
73 Qtt_scope,
74 Qtt_sender,
75 Qtt_sender_ptype,
76 Qtt_session,
77 Qtt_state,
78 Qtt_status,
79 Qtt_status_string,
80 Qtt_uid,
81 Qtt_callback,
82 Qtt_plist,
83 Qtt_prop,
84
85 Qtt_reject, /* return-tooltalk-message */
86 Qtt_reply,
87 Qtt_fail,
88
89 Q_TT_MODE_UNDEFINED, /* enum Tt_mode */
90 Q_TT_IN,
91 Q_TT_OUT,
92 Q_TT_INOUT,
93 Q_TT_MODE_LAST,
94
95 Q_TT_SCOPE_NONE, /* enum Tt_scope */
96 Q_TT_SESSION,
97 Q_TT_FILE,
98 Q_TT_BOTH,
99 Q_TT_FILE_IN_SESSION,
100
101 Q_TT_CLASS_UNDEFINED, /* enum Tt_class */
102 Q_TT_NOTICE,
103 Q_TT_REQUEST,
104 Q_TT_CLASS_LAST,
105
106 Q_TT_CATEGORY_UNDEFINED, /* enum Tt_category */
107 Q_TT_OBSERVE,
108 Q_TT_HANDLE,
109 Q_TT_CATEGORY_LAST,
110
111 Q_TT_PROCEDURE, /* typedef enum Tt_address */
112 Q_TT_OBJECT,
113 Q_TT_HANDLER,
114 Q_TT_OTYPE,
115 Q_TT_ADDRESS_LAST,
116
117 Q_TT_CREATED, /* enum Tt_state */
118 Q_TT_SENT,
119 Q_TT_HANDLED,
120 Q_TT_FAILED,
121 Q_TT_QUEUED,
122 Q_TT_STARTED,
123 Q_TT_REJECTED,
124 Q_TT_STATE_LAST,
125
126 Q_TT_DISCARD, /* enum Tt_disposition */
127 Q_TT_QUEUE,
128 Q_TT_START;
129
130 static Lisp_Object Tooltalk_Message_plist_str, Tooltalk_Pattern_plist_str;
131
132 Lisp_Object Qtooltalk_error;
133
134 /* Used to GCPRO tooltalk message and pattern objects while
135 they're sitting inside of some active tooltalk message or pattern.
136 There may not be any other pointers to these objects. */
137 Lisp_Object Vtooltalk_message_gcpro, Vtooltalk_pattern_gcpro;
138
139
140 /* */
141 /* machinery for tooltalk-message type */
142 /* */
143
144 Lisp_Object Qtooltalk_messagep;
145
146 struct Lisp_Tooltalk_Message
147 {
148 struct lcrecord_header header;
149 Lisp_Object plist_sym, callback;
150 Tt_message m;
151 };
152
153 static Lisp_Object
154 mark_tooltalk_message (Lisp_Object obj)
155 {
156 mark_object (XTOOLTALK_MESSAGE (obj)->callback);
157 return XTOOLTALK_MESSAGE (obj)->plist_sym;
158 }
159
160 static void
161 print_tooltalk_message (Lisp_Object obj, Lisp_Object printcharfun,
162 int escapeflag)
163 {
164 struct Lisp_Tooltalk_Message *p = XTOOLTALK_MESSAGE (obj);
165
166 char buf[200];
167
168 if (print_readably)
169 error ("printing unreadable object #<tooltalk_message 0x%x>",
170 p->header.uid);
171
172 sprintf (buf, "#<tooltalk_message id:0x%lx 0x%x>", (long) (p->m), p->header.uid);
173 write_c_string (buf, printcharfun);
174 }
175
176 DEFINE_LRECORD_IMPLEMENTATION ("tooltalk-message", tooltalk_message,
177 mark_tooltalk_message, print_tooltalk_message,
178 0, 0, 0, 0,
179 struct Lisp_Tooltalk_Message);
180
181 static Lisp_Object
182 make_tooltalk_message (Tt_message m)
183 {
184 Lisp_Object val;
185 struct Lisp_Tooltalk_Message *msg =
186 alloc_lcrecord_type (struct Lisp_Tooltalk_Message,
187 &lrecord_tooltalk_message);
188
189 msg->m = m;
190 msg->callback = Qnil;
191 msg->plist_sym = Fmake_symbol (Tooltalk_Message_plist_str);
192 XSETTOOLTALK_MESSAGE (val, msg);
193 return val;
194 }
195
196 Tt_message
197 unbox_tooltalk_message (Lisp_Object msg)
198 {
199 CHECK_TOOLTALK_MESSAGE (msg);
200 return XTOOLTALK_MESSAGE (msg)->m;
201 }
202
203 DEFUN ("tooltalk-message-p", Ftooltalk_message_p, 1, 1, 0, /*
204 Return non-nil if OBJECT is a tooltalk message.
205 */
206 (object))
207 {
208 return TOOLTALK_MESSAGEP (object) ? Qt : Qnil;
209 }
210
211
212
213
214 /* */
215 /* machinery for tooltalk-pattern type */
216 /* */
217
218 Lisp_Object Qtooltalk_patternp;
219
220 struct Lisp_Tooltalk_Pattern
221 {
222 struct lcrecord_header header;
223 Lisp_Object plist_sym, callback;
224 Tt_pattern p;
225 };
226
227 static Lisp_Object
228 mark_tooltalk_pattern (Lisp_Object obj)
229 {
230 mark_object (XTOOLTALK_PATTERN (obj)->callback);
231 return XTOOLTALK_PATTERN (obj)->plist_sym;
232 }
233
234 static void
235 print_tooltalk_pattern (Lisp_Object obj, Lisp_Object printcharfun,
236 int escapeflag)
237 {
238 struct Lisp_Tooltalk_Pattern *p = XTOOLTALK_PATTERN (obj);
239
240 char buf[200];
241
242 if (print_readably)
243 error ("printing unreadable object #<tooltalk_pattern 0x%x>",
244 p->header.uid);
245
246 sprintf (buf, "#<tooltalk_pattern id:0x%lx 0x%x>", (long) (p->p), p->header.uid);
247 write_c_string (buf, printcharfun);
248 }
249
250 DEFINE_LRECORD_IMPLEMENTATION ("tooltalk-pattern", tooltalk_pattern,
251 mark_tooltalk_pattern, print_tooltalk_pattern,
252 0, 0, 0, 0,
253 struct Lisp_Tooltalk_Pattern);
254
255 static Lisp_Object
256 make_tooltalk_pattern (Tt_pattern p)
257 {
258 struct Lisp_Tooltalk_Pattern *pat =
259 alloc_lcrecord_type (struct Lisp_Tooltalk_Pattern,
260 &lrecord_tooltalk_pattern);
261 Lisp_Object val;
262
263 pat->p = p;
264 pat->callback = Qnil;
265 pat->plist_sym = Fmake_symbol (Tooltalk_Pattern_plist_str);
266
267 XSETTOOLTALK_PATTERN (val, pat);
268 return val;
269 }
270
271 static Tt_pattern
272 unbox_tooltalk_pattern (Lisp_Object pattern)
273 {
274 CHECK_TOOLTALK_PATTERN (pattern);
275 return XTOOLTALK_PATTERN (pattern)->p;
276 }
277
278 DEFUN ("tooltalk-pattern-p", Ftooltalk_pattern_p, 1, 1, 0, /*
279 Return non-nil if OBJECT is a tooltalk pattern.
280 */
281 (object))
282 {
283 return TOOLTALK_PATTERNP (object) ? Qt : Qnil;
284 }
285
286
287
288
289 static int
290 tooltalk_constant_value (Lisp_Object s)
291 {
292 if (INTP (s))
293 return XINT (s);
294 else if (SYMBOLP (s))
295 return XINT (XSYMBOL (s)->value);
296 else
297 return 0; /* should never occur */
298 }
299
300 static void
301 check_status (Tt_status st)
302 {
303 if (tt_is_err (st))
304 signal_error (Qtooltalk_error,
305 Fcons (build_string (tt_status_message (st)), Qnil));
306 }
307
308 DEFUN ("receive-tooltalk-message", Freceive_tooltalk_message, 0, 2, 0, /*
309 Run tt_message_receive().
310 This function is the process handler for the ToolTalk connection process.
311 */
312 (ignore1, ignore2))
313 {
314 /* This function can GC */
315 Tt_message mess = tt_message_receive ();
316 Lisp_Object message_ = make_tooltalk_message (mess);
317 struct gcpro gcpro1;
318
319 GCPRO1 (message_);
320 if (mess != NULL && !NILP (Vtooltalk_unprocessed_message_hook))
321 va_run_hook_with_args (Qtooltalk_unprocessed_message_hook, 1, message_);
322 UNGCPRO;
323
324 /* see comment in event-stream.c about this return value. */
325 return Qzero;
326 }
327
328 static Tt_callback_action
329 tooltalk_message_callback (Tt_message m, Tt_pattern p)
330 {
331 /* This function can GC */
332 Lisp_Object cb;
333 Lisp_Object message_;
334 Lisp_Object pattern;
335 struct gcpro gcpro1, gcpro2;
336
337 #ifdef TT_DEBUG
338 int i, j;
339
340 fprintf (tooltalk_log_file, "message_cb: %d\n", m);
341 fprintf (tooltalk_log_file, "op: %s (", tt_message_op (m));
342 for (j = tt_message_args_count (m), i = 0; i < j; i++) {
343 fprintf (tooltalk_log_file, "%s \"%s\"", tt_message_arg_type (m, i),
344 tt_message_arg_val (m, i));
345 fprintf (tooltalk_log_file, "%s", i == j-1 ? ")" : ", ");
346 }
347 fprintf (tooltalk_log_file, "\n\n");
348 fflush (tooltalk_log_file);
349 #endif
350
351 VOID_TO_LISP (message_, tt_message_user (m, TOOLTALK_MESSAGE_KEY));
352 pattern = make_tooltalk_pattern (p);
353 cb = XTOOLTALK_MESSAGE (message_)->callback;
354 GCPRO2 (message_, pattern);
355 if (!NILP (Vtooltalk_message_handler_hook))
356 va_run_hook_with_args (Qtooltalk_message_handler_hook, 2,
357 message_, pattern);
358
359 if ((SYMBOLP (cb) && EQ (Qt, Ffboundp (cb))) ||
360 (CONSP (cb) && EQ (Qlambda, Fcar (cb)) &&
361 !NILP (Flistp (Fcar (Fcdr (cb))))))
362 call2 (cb, message_, pattern);
363 UNGCPRO;
364
365 tt_message_destroy (m);
366 Fremhash (message_, Vtooltalk_message_gcpro);
367
368 return TT_CALLBACK_PROCESSED;
369 }
370
371 static Tt_callback_action
372 tooltalk_pattern_callback (Tt_message m, Tt_pattern p)
373 {
374 /* This function can GC */
375 Lisp_Object cb;
376 Lisp_Object message_;
377 Lisp_Object pattern;
378 struct gcpro gcpro1, gcpro2;
379
380 #ifdef TT_DEBUG
381 int i, j;
382
383 fprintf (tooltalk_log_file, "pattern_cb: %d\n", m);
384 fprintf (tooltalk_log_file, "op: %s (", tt_message_op (m));
385 for (j = tt_message_args_count (m), i = 0; i < j; i++) {
386 fprintf (tooltalk_log_file, "%s \"%s\"", tt_message_arg_type (m, i),
387 tt_message_arg_val (m, i));
388 fprintf (tooltalk_log_file, "%s", i == j-1 ? ")" : ", ");
389 }
390 fprintf (tooltalk_log_file, "\n\n");
391 fflush (tooltalk_log_file);
392 #endif
393
394 message_ = make_tooltalk_message (m);
395 VOID_TO_LISP (pattern, tt_pattern_user (p, TOOLTALK_PATTERN_KEY));
396 cb = XTOOLTALK_PATTERN (pattern)->callback;
397 GCPRO2 (message_, pattern);
398 if (!NILP (Vtooltalk_pattern_handler_hook))
399 va_run_hook_with_args (Qtooltalk_pattern_handler_hook, 2,
400 message_, pattern);
401
402 if (SYMBOLP (cb) && EQ (Qt, Ffboundp (cb)))
403 call2 (cb, message_, pattern);
404 UNGCPRO;
405
406 tt_message_destroy (m);
407 return TT_CALLBACK_PROCESSED;
408 }
409
410 static Lisp_Object
411 tt_mode_symbol (Tt_mode n)
412 {
413 switch (n)
414 {
415 case TT_MODE_UNDEFINED: return Q_TT_MODE_UNDEFINED;
416 case TT_IN: return Q_TT_IN;
417 case TT_OUT: return Q_TT_OUT;
418 case TT_INOUT: return Q_TT_INOUT;
419 case TT_MODE_LAST: return Q_TT_MODE_LAST;
420 default: return Qnil;
421 }
422 }
423
424 static Lisp_Object
425 tt_scope_symbol (Tt_scope n)
426 {
427 switch (n)
428 {
429 case TT_SCOPE_NONE: return Q_TT_SCOPE_NONE;
430 case TT_SESSION: return Q_TT_SESSION;
431 case TT_FILE: return Q_TT_FILE;
432 case TT_BOTH: return Q_TT_BOTH;
433 case TT_FILE_IN_SESSION: return Q_TT_FILE_IN_SESSION;
434 default: return Qnil;
435 }
436 }
437
438
439 static Lisp_Object
440 tt_class_symbol (Tt_class n)
441 {
442 switch (n)
443 {
444 case TT_CLASS_UNDEFINED: return Q_TT_CLASS_UNDEFINED;
445 case TT_NOTICE: return Q_TT_NOTICE;
446 case TT_REQUEST: return Q_TT_REQUEST;
447 case TT_CLASS_LAST: return Q_TT_CLASS_LAST;
448 default: return Qnil;
449 }
450 }
451
452 /*
453 * This is not being used. Is that a mistake or is this function
454 * simply not necessary?
455 */
456 #if 0
457 static Lisp_Object
458 tt_category_symbol (Tt_category n)
459 {
460 switch (n)
461 {
462 case TT_CATEGORY_UNDEFINED: return Q_TT_CATEGORY_UNDEFINED;
463 case TT_OBSERVE: return Q_TT_OBSERVE;
464 case TT_HANDLE: return Q_TT_HANDLE;
465 case TT_CATEGORY_LAST: return Q_TT_CATEGORY_LAST;
466 default: return Qnil;
467 }
468 }
469 #endif /* 0 */
470
471 static Lisp_Object
472 tt_address_symbol (Tt_address n)
473 {
474 switch (n)
475 {
476 case TT_PROCEDURE: return Q_TT_PROCEDURE;
477 case TT_OBJECT: return Q_TT_OBJECT;
478 case TT_HANDLER: return Q_TT_HANDLER;
479 case TT_OTYPE: return Q_TT_OTYPE;
480 case TT_ADDRESS_LAST: return Q_TT_ADDRESS_LAST;
481 default: return Qnil;
482 }
483 }
484
485 static Lisp_Object
486 tt_state_symbol (Tt_state n)
487 {
488 switch (n)
489 {
490 case TT_CREATED: return Q_TT_CREATED;
491 case TT_SENT: return Q_TT_SENT;
492 case TT_HANDLED: return Q_TT_HANDLED;
493 case TT_FAILED: return Q_TT_FAILED;
494 case TT_QUEUED: return Q_TT_QUEUED;
495 case TT_STARTED: return Q_TT_STARTED;
496 case TT_REJECTED: return Q_TT_REJECTED;
497 case TT_STATE_LAST: return Q_TT_STATE_LAST;
498 default: return Qnil;
499 }
500 }
501
502 static Lisp_Object
503 tt_build_string (char *s)
504 {
505 return build_string (s ? s : "");
506 }
507
508 static Lisp_Object
509 tt_opnum_string (int n)
510 {
511 char buf[32];
512
513 sprintf (buf, "%u", n);
514 return build_string (buf);
515 }
516
517 static Lisp_Object
518 tt_message_arg_ival_string (Tt_message m, int n)
519 {
520 char buf[32];
521 int value;
522
523 check_status (tt_message_arg_ival (m, n, &value));
524 long_to_string (buf, value);
525 return build_string (buf);
526 }
527
528 static Lisp_Object
529 tt_message_arg_bval_vector (Tt_message m, int n)
530 {
531 /* !!#### This function has not been Mule-ized */
532 Bufbyte *value;
533 int len = 0;
534
535 check_status (tt_message_arg_bval (m, n, &value, &len));
536
537 return make_string (value, len);
538 }
539
540 DEFUN ("get-tooltalk-message-attribute", Fget_tooltalk_message_attribute,
541 2, 3, 0, /*
542 Return the indicated Tooltalk message attribute. Attributes are
543 identified by symbols with the same name (underscores and all) as the
544 suffix of the Tooltalk tt_message_<attribute> function that extracts the value.
545 String attribute values are copied, enumerated type values (except disposition)
546 are converted to symbols - e.g. TT_HANDLER is 'TT_HANDLER, uid and gid are
547 represented by fixnums (small integers), opnum is converted to a string,
548 and disposition is converted to a fixnum. We convert opnum (a C int) to a
549 string, e.g. 123 => "123" because there's no guarantee that opnums will fit
550 within the range of Lisp integers.
551
552 Use the 'plist attribute instead of the C API 'user attribute
553 for user defined message data. To retrieve the value of a message property
554 specify the indicator for argn. For example to get the value of a property
555 called 'rflag, use
556 (get-tooltalk-message-attribute message 'plist 'rflag)
557
558 To get the value of a message argument use one of the 'arg_val (strings),
559 'arg_ival (integers), or 'arg_bval (strings with embedded nulls), attributes.
560 For example to get the integer value of the third argument:
561
562 (get-tooltalk-message-attribute message 'arg_ival 2)
563
564 As you can see, argument numbers are zero based. The type of each argument
565 can be retrieved with the 'arg_type attribute; however, Tooltalk doesn't
566 define any semantics for the string value of 'arg_type. Conventionally
567 "string" is used for strings and "int" for 32 bit integers. Note that
568 Emacs Lisp stores the lengths of strings explicitly (unlike C) so treating the
569 value returned by 'arg_bval like a string is fine.
570 */
571 (message_, attribute, argn))
572 {
573 Tt_message m = unbox_tooltalk_message (message_);
574 int n = 0;
575
576 CHECK_SYMBOL (attribute);
577 if (EQ (attribute, (Qtt_arg_bval)) ||
578 EQ (attribute, (Qtt_arg_ival)) ||
579 EQ (attribute, (Qtt_arg_mode)) ||
580 EQ (attribute, (Qtt_arg_type)) ||
581 EQ (attribute, (Qtt_arg_val)))
582 {
583 CHECK_INT (argn);
584 n = XINT (argn);
585 }
586
587 if (!VALID_TOOLTALK_MESSAGEP (m))
588 return Qnil;
589
590 else if (EQ (attribute, Qtt_arg_bval))
591 return tt_message_arg_bval_vector (m, n);
592
593 else if (EQ (attribute, Qtt_arg_ival))
594 return tt_message_arg_ival_string (m, n);
595
596 else if (EQ (attribute, Qtt_arg_mode))
597 return tt_mode_symbol (tt_message_arg_mode (m, n));
598
599 else if (EQ (attribute, Qtt_arg_type))
600 return tt_build_string (tt_message_arg_type (m, n));
601
602 else if (EQ (attribute, Qtt_arg_val))
603 return tt_message_arg_bval_vector (m, n);
604
605 else if (EQ (attribute, Qtt_args_count))
606 return make_int (tt_message_args_count (m));
607
608 else if (EQ (attribute, Qtt_address))
609 return tt_address_symbol (tt_message_address (m));
610
611 else if (EQ (attribute, Qtt_class))
612 return tt_class_symbol (tt_message_class (m));
613
614 else if (EQ (attribute, Qtt_disposition))
615 return make_int (tt_message_disposition (m));
616
617 else if (EQ (attribute, Qtt_file))
618 return tt_build_string (tt_message_file (m));
619
620 else if (EQ (attribute, Qtt_gid))
621 return make_int (tt_message_gid (m));
622
623 else if (EQ (attribute, Qtt_handler))
624 return tt_build_string (tt_message_handler (m));
625
626 else if (EQ (attribute, Qtt_handler_ptype))
627 return tt_build_string (tt_message_handler_ptype (m));
628
629 else if (EQ (attribute, Qtt_object))
630 return tt_build_string (tt_message_object (m));
631
632 else if (EQ (attribute, Qtt_op))
633 return tt_build_string (tt_message_op (m));
634
635 else if (EQ (attribute, Qtt_opnum))
636 return tt_opnum_string (tt_message_opnum (m));
637
638 else if (EQ (attribute, Qtt_otype))
639 return tt_build_string (tt_message_otype (m));
640
641 else if (EQ (attribute, Qtt_scope))
642 return tt_scope_symbol (tt_message_scope (m));
643
644 else if (EQ (attribute, Qtt_sender))
645 return tt_build_string (tt_message_sender (m));
646
647 else if (EQ (attribute, Qtt_sender_ptype))
648 return tt_build_string (tt_message_sender_ptype (m));
649
650 else if (EQ (attribute, Qtt_session))
651 return tt_build_string (tt_message_session (m));
652
653 else if (EQ (attribute, Qtt_state))
654 return tt_state_symbol (tt_message_state (m));
655
656 else if (EQ (attribute, Qtt_status))
657 return make_int (tt_message_status (m));
658
659 else if (EQ (attribute, Qtt_status_string))
660 return tt_build_string (tt_message_status_string (m));
661
662 else if (EQ (attribute, Qtt_uid))
663 return make_int (tt_message_uid (m));
664
665 else if (EQ (attribute, Qtt_callback))
666 return XTOOLTALK_MESSAGE (message_)->callback;
667
668 else if (EQ (attribute, Qtt_prop))
669 return Fget (XTOOLTALK_MESSAGE (message_)->plist_sym, argn, Qnil);
670
671 else if (EQ (attribute, Qtt_plist))
672 return Fcopy_sequence (Fsymbol_plist
673 (XTOOLTALK_MESSAGE (message_)->plist_sym));
674
675 else
676 signal_simple_error ("Invalid value for `get-tooltalk-message-attribute'",
677 attribute);
678
679 return Qnil;
680 }
681
682 DEFUN ("set-tooltalk-message-attribute", Fset_tooltalk_message_attribute,
683 3, 4, 0, /*
684 Initialize one Tooltalk message attribute.
685
686 Attribute names and values are the same as for
687 `get-tooltalk-message-attribute'. A property list is provided for user
688 data (instead of the 'user message attribute); see
689 `get-tooltalk-message-attribute'.
690
691 The value of callback should be the name of a function of one argument.
692 It will be applied to the message and matching pattern each time the state of the
693 message changes. This is usually used to notice when the messages state has
694 changed to TT_HANDLED (or TT_FAILED), so that reply argument values
695 can be used.
696
697 If one of the argument attributes is specified, 'arg_val, 'arg_ival, or
698 'arg_bval then argn must be the number of an already created argument.
699 New arguments can be added to a message with add-tooltalk-message-arg.
700 */
701 (value, message_, attribute, argn))
702 {
703 Tt_message m = unbox_tooltalk_message (message_);
704 int n = 0;
705
706 CHECK_SYMBOL (attribute);
707 if (EQ (attribute, (Qtt_arg_bval)) ||
708 EQ (attribute, (Qtt_arg_ival)) ||
709 EQ (attribute, (Qtt_arg_val)))
710 {
711 CHECK_INT (argn);
712 n = XINT (argn);
713 }
714
715 if (!VALID_TOOLTALK_MESSAGEP (m))
716 return Qnil;
717
718 else if (EQ (attribute, Qtt_address))
719 {
720 CHECK_TOOLTALK_CONSTANT (value);
721 tt_message_address_set (m, (Tt_address) tooltalk_constant_value (value));
722 }
723 else if (EQ (attribute, Qtt_class))
724 {
725 CHECK_TOOLTALK_CONSTANT (value);
726 tt_message_class_set (m, (Tt_class) tooltalk_constant_value (value));
727 }
728 else if (EQ (attribute, Qtt_disposition))
729 {
730 CHECK_TOOLTALK_CONSTANT (value);
731 tt_message_disposition_set (m, ((Tt_disposition)
732 tooltalk_constant_value (value)));
733 }
734 else if (EQ (attribute, Qtt_file))
735 {
736 CONST char *value_ext;
737 CHECK_STRING (value);
738 GET_C_STRING_OS_DATA_ALLOCA (value, value_ext);
739 tt_message_file_set (m, value_ext);
740 }
741 else if (EQ (attribute, Qtt_handler_ptype))
742 {
743 CONST char *value_ext;
744 CHECK_STRING (value);
745 GET_C_STRING_OS_DATA_ALLOCA (value, value_ext);
746 tt_message_handler_ptype_set (m, value_ext);
747 }
748 else if (EQ (attribute, Qtt_handler))
749 {
750 CONST char *value_ext;
751 CHECK_STRING (value);
752 GET_C_STRING_OS_DATA_ALLOCA (value, value_ext);
753 tt_message_handler_set (m, value_ext);
754 }
755 else if (EQ (attribute, Qtt_object))
756 {
757 CONST char *value_ext;
758 CHECK_STRING (value);
759 GET_C_STRING_OS_DATA_ALLOCA (value, value_ext);
760 tt_message_object_set (m, value_ext);
761 }
762 else if (EQ (attribute, Qtt_op))
763 {
764 CONST char *value_ext;
765 CHECK_STRING (value);
766 GET_C_STRING_OS_DATA_ALLOCA (value, value_ext);
767 tt_message_op_set (m, value_ext);
768 }
769 else if (EQ (attribute, Qtt_otype))
770 {
771 CONST char *value_ext;
772 CHECK_STRING (value);
773 GET_C_STRING_OS_DATA_ALLOCA (value, value_ext);
774 tt_message_otype_set (m, value_ext);
775 }
776 else if (EQ (attribute, Qtt_scope))
777 {
778 CHECK_TOOLTALK_CONSTANT (value);
779 tt_message_scope_set (m, (Tt_scope) tooltalk_constant_value (value));
780 }
781 else if (EQ (attribute, Qtt_sender_ptype))
782 {
783 CONST char *value_ext;
784 CHECK_STRING (value);
785 GET_C_STRING_OS_DATA_ALLOCA (value, value_ext);
786 tt_message_sender_ptype_set (m, value_ext);
787 }
788 else if (EQ (attribute, Qtt_session))
789 {
790 CONST char *value_ext;
791 CHECK_STRING (value);
792 GET_C_STRING_OS_DATA_ALLOCA (value, value_ext);
793 tt_message_session_set (m, value_ext);
794 }
795 else if (EQ (attribute, Qtt_arg_bval))
796 {
797 Extbyte *value_ext;
798 Extcount value_ext_len;
799 CHECK_STRING (value);
800 GET_STRING_OS_DATA_ALLOCA (value, value_ext, value_ext_len);
801 tt_message_arg_bval_set (m, n, value_ext, value_ext_len);
802 }
803 else if (EQ (attribute, Qtt_arg_ival))
804 {
805 CHECK_INT (value);
806 tt_message_arg_ival_set (m, n, XINT (value));
807 }
808 else if (EQ (attribute, Qtt_arg_val))
809 {
810 CONST char *value_ext;
811 CHECK_STRING (value);
812 GET_C_STRING_OS_DATA_ALLOCA (value, value_ext);
813 tt_message_arg_val_set (m, n, value_ext);
814 }
815 else if (EQ (attribute, Qtt_status))
816 {
817 CHECK_INT (value);
818 tt_message_status_set (m, XINT (value));
819 }
820 else if (EQ (attribute, Qtt_status_string))
821 {
822 CONST char *value_ext;
823 CHECK_STRING (value);
824 GET_C_STRING_OS_DATA_ALLOCA (value, value_ext);
825 tt_message_status_string_set (m, value_ext);
826 }
827 else if (EQ (attribute, Qtt_callback))
828 {
829 CHECK_SYMBOL (value);
830 XTOOLTALK_MESSAGE (message_)->callback = value;
831 }
832 else if (EQ (attribute, Qtt_prop))
833 {
834 return Fput (XTOOLTALK_MESSAGE (message_)->plist_sym, argn, value);
835 }
836 else
837 signal_simple_error ("Invalid value for `set-tooltalk-message-attribute'",
838 attribute);
839 return Qnil;
840 }
841
842 DEFUN ("return-tooltalk-message", Freturn_tooltalk_message, 1, 2, 0, /*
843 Send a reply to this message. The second argument can be
844 'reply, 'reject or 'fail; the default is 'reply. Before sending
845 a reply all message arguments whose mode is TT_INOUT or TT_OUT should
846 have been filled in - see set-tooltalk-message-attribute.
847 */
848 (message_, mode))
849 {
850 Tt_message m = unbox_tooltalk_message (message_);
851
852 if (NILP (mode))
853 mode = Qtt_reply;
854 else
855 CHECK_SYMBOL (mode);
856
857 if (!VALID_TOOLTALK_MESSAGEP (m))
858 return Qnil;
859 else if (EQ (mode, Qtt_reply))
860 tt_message_reply (m);
861 else if (EQ (mode, Qtt_reject))
862 tt_message_reject (m);
863 else if (EQ (mode, Qtt_fail))
864 tt_message_fail (m);
865
866 return Qnil;
867 }
868
869 DEFUN ("create-tooltalk-message", Fcreate_tooltalk_message, 0, 1, 0, /*
870 Create a new tooltalk message.
871 The messages session attribute is initialized to the default session.
872 Other attributes can be initialized with `set-tooltalk-message-attribute'.
873 `make-tooltalk-message' is the preferred to create and initialize a message.
874
875 Optional arg NO-CALLBACK says don't add a C-level callback at all.
876 Normally don't do that; just don't specify the Lisp callback when
877 calling `make-tooltalk-message'.
878 */
879 (no_callback))
880 {
881 Tt_message m = tt_message_create ();
882 Lisp_Object message_ = make_tooltalk_message (m);
883 if (NILP (no_callback))
884 {
885 tt_message_callback_add (m, tooltalk_message_callback);
886 }
887 tt_message_session_set (m, tt_default_session ());
888 tt_message_user_set (m, TOOLTALK_MESSAGE_KEY, LISP_TO_VOID (message_));
889 return message_;
890 }
891
892 DEFUN ("destroy-tooltalk-message", Fdestroy_tooltalk_message, 1, 1, 0, /*
893 Apply tt_message_destroy() to the message.
894 It's not necessary to destroy messages after they've been processed by
895 a message or pattern callback; the Lisp/Tooltalk callback machinery does
896 this for you.
897 */
898 (message_))
899 {
900 Tt_message m = unbox_tooltalk_message (message_);
901
902 if (VALID_TOOLTALK_MESSAGEP (m))
903 /* #### Should we call Fremhash() here? It seems that
904 a common paradigm is
905
906 (send-tooltalk-message)
907 (destroy-tooltalk-message)
908
909 which would imply that destroying a sent ToolTalk message
910 doesn't actually destroy it; when a response is sent back,
911 the callback for the message will still be called.
912
913 But then maybe not: Maybe it really does destroy it,
914 and the reason for that paradigm is that the author
915 of `send-tooltalk-message' didn't really know what he
916 was talking about when he said that it's a good idea
917 to call `destroy-tooltalk-message' after sending it. */
918 tt_message_destroy (m);
919
920 return Qnil;
921 }
922
923
924 DEFUN ("add-tooltalk-message-arg", Fadd_tooltalk_message_arg, 3, 4, 0, /*
925 Append one new argument to the message.
926 MODE must be one of TT_IN, TT_INOUT, or TT_OUT; VTYPE must be a string;
927 and VALUE can be a string or an integer. Tooltalk doesn't
928 define any semantics for VTYPE, so only the participants in the
929 protocol you're using need to agree what types mean (if anything).
930 Conventionally "string" is used for strings and "int" for 32 bit integers.
931 Arguments can initialized by providing a value or with
932 `set-tooltalk-message-attribute'. The latter is necessary if you
933 want to initialize the argument with a string that can contain
934 embedded nulls (use 'arg_bval).
935 */
936 (message_, mode, vtype, value))
937 {
938 Tt_message m = unbox_tooltalk_message (message_);
939 Tt_mode n;
940
941 CHECK_STRING (vtype);
942 CHECK_TOOLTALK_CONSTANT (mode);
943
944 n = (Tt_mode) tooltalk_constant_value (mode);
945
946 if (!VALID_TOOLTALK_MESSAGEP (m))
947 return Qnil;
948 {
949 CONST char *vtype_ext;
950
951 GET_C_STRING_OS_DATA_ALLOCA (vtype, vtype_ext);
952 if (NILP (value))
953 tt_message_arg_add (m, n, vtype_ext, NULL);
954 else if (STRINGP (value))
955 {
956 CONST char *value_ext;
957 GET_C_STRING_OS_DATA_ALLOCA (value, value_ext);
958 tt_message_arg_add (m, n, vtype_ext, value_ext);
959 }
960 else if (INTP (value))
961 tt_message_iarg_add (m, n, vtype_ext, XINT (value));
962 }
963
964 return Qnil;
965 }
966
967 DEFUN ("send-tooltalk-message", Fsend_tooltalk_message, 1, 1, 0, /*
968 Send the message on its way.
969 Once the message has been sent it's almost always a good idea to get rid of
970 it with `destroy-tooltalk-message'.
971 */
972 (message_))
973 {
974 Tt_message m = unbox_tooltalk_message (message_);
975
976 if (VALID_TOOLTALK_MESSAGEP (m))
977 {
978 tt_message_send (m);
979 Fputhash (message_, Qnil, Vtooltalk_message_gcpro);
980 }
981
982 return Qnil;
983 }
984
985 DEFUN ("create-tooltalk-pattern", Fcreate_tooltalk_pattern, 0, 0, 0, /*
986 Create a new Tooltalk pattern.
987 Its session attribute is initialized to be the default session.
988 */
989 ())
990 {
991 Tt_pattern p = tt_pattern_create ();
992 Lisp_Object pattern = make_tooltalk_pattern (p);
993
994 tt_pattern_callback_add (p, tooltalk_pattern_callback);
995 tt_pattern_session_add (p, tt_default_session ());
996 tt_pattern_user_set (p, TOOLTALK_PATTERN_KEY, LISP_TO_VOID (pattern));
997
998 return pattern;
999 }
1000
1001
1002 DEFUN ("destroy-tooltalk-pattern", Fdestroy_tooltalk_pattern, 1, 1, 0, /*
1003 Apply tt_pattern_destroy() to the pattern.
1004 This effectively unregisters the pattern.
1005 */
1006 (pattern))
1007 {
1008 Tt_pattern p = unbox_tooltalk_pattern (pattern);
1009
1010 if (VALID_TOOLTALK_PATTERNP (p))
1011 {
1012 tt_pattern_destroy (p);
1013 Fremhash (pattern, Vtooltalk_pattern_gcpro);
1014 }
1015
1016 return Qnil;
1017 }
1018
1019
1020 DEFUN ("add-tooltalk-pattern-attribute", Fadd_tooltalk_pattern_attribute, 3, 3, 0, /*
1021 Add one value to the indicated pattern attribute.
1022 All Tooltalk pattern attributes are supported except 'user. The names
1023 of attributes are the same as the Tooltalk accessors used to set them
1024 less the "tooltalk_pattern_" prefix and the "_add" ...
1025 */
1026 (value, pattern, attribute))
1027 {
1028 Tt_pattern p = unbox_tooltalk_pattern (pattern);
1029
1030 CHECK_SYMBOL (attribute);
1031
1032 if (!VALID_TOOLTALK_PATTERNP (p))
1033 return Qnil;
1034
1035 else if (EQ (attribute, Qtt_category))
1036 {
1037 CHECK_TOOLTALK_CONSTANT (value);
1038 tt_pattern_category_set (p, ((Tt_category)
1039 tooltalk_constant_value (value)));
1040 }
1041 else if (EQ (attribute, Qtt_address))
1042 {
1043 CHECK_TOOLTALK_CONSTANT (value);
1044 tt_pattern_address_add (p, ((Tt_address)
1045 tooltalk_constant_value (value)));
1046 }
1047 else if (EQ (attribute, Qtt_class))
1048 {
1049 CHECK_TOOLTALK_CONSTANT (value);
1050 tt_pattern_class_add (p, (Tt_class) tooltalk_constant_value (value));
1051 }
1052 else if (EQ (attribute, Qtt_disposition))
1053 {
1054 CHECK_TOOLTALK_CONSTANT (value);
1055 tt_pattern_disposition_add (p, ((Tt_disposition)
1056 tooltalk_constant_value (value)));
1057 }
1058 else if (EQ (attribute, Qtt_file))
1059 {
1060 CONST char *value_ext;
1061 CHECK_STRING (value);
1062 GET_C_STRING_OS_DATA_ALLOCA (value, value_ext);
1063 tt_pattern_file_add (p, value_ext);
1064 }
1065 else if (EQ (attribute, Qtt_object))
1066 {
1067 CONST char *value_ext;
1068 CHECK_STRING (value);
1069 GET_C_STRING_OS_DATA_ALLOCA (value, value_ext);
1070 tt_pattern_object_add (p, value_ext);
1071 }
1072 else if (EQ (attribute, Qtt_op))
1073 {
1074 CONST char *value_ext;
1075 CHECK_STRING (value);
1076 GET_C_STRING_OS_DATA_ALLOCA (value, value_ext);
1077 tt_pattern_op_add (p, value_ext);
1078 }
1079 else if (EQ (attribute, Qtt_otype))
1080 {
1081 CONST char *value_ext;
1082 CHECK_STRING (value);
1083 GET_C_STRING_OS_DATA_ALLOCA (value, value_ext);
1084 tt_pattern_otype_add (p, value_ext);
1085 }
1086 else if (EQ (attribute, Qtt_scope))
1087 {
1088 CHECK_TOOLTALK_CONSTANT (value);
1089 tt_pattern_scope_add (p, (Tt_scope) tooltalk_constant_value (value));
1090 }
1091 else if (EQ (attribute, Qtt_sender))
1092 {
1093 CONST char *value_ext;
1094 CHECK_STRING (value);
1095 GET_C_STRING_OS_DATA_ALLOCA (value, value_ext);
1096 tt_pattern_sender_add (p, value_ext);
1097 }
1098 else if (EQ (attribute, Qtt_sender_ptype))
1099 {
1100 CONST char *value_ext;
1101 CHECK_STRING (value);
1102 GET_C_STRING_OS_DATA_ALLOCA (value, value_ext);
1103 tt_pattern_sender_ptype_add (p, value_ext);
1104 }
1105 else if (EQ (attribute, Qtt_session))
1106 {
1107 CONST char *value_ext;
1108 CHECK_STRING (value);
1109 GET_C_STRING_OS_DATA_ALLOCA (value, value_ext);
1110 tt_pattern_session_add (p, value_ext);
1111 }
1112 else if (EQ (attribute, Qtt_state))
1113 {
1114 CHECK_TOOLTALK_CONSTANT (value);
1115 tt_pattern_state_add (p, (Tt_state) tooltalk_constant_value (value));
1116 }
1117 else if (EQ (attribute, Qtt_callback))
1118 {
1119 CHECK_SYMBOL (value);
1120 XTOOLTALK_PATTERN (pattern)->callback = value;
1121 }
1122
1123 return Qnil;
1124 }
1125
1126
1127 DEFUN ("add-tooltalk-pattern-arg", Fadd_tooltalk_pattern_arg, 3, 4, 0, /*
1128 Add one fully specified argument to a tooltalk pattern.
1129 Mode must be one of TT_IN, TT_INOUT, or TT_OUT, type must be a string.
1130 Value can be an integer, string or nil. If value is an integer then
1131 an integer argument (tt_pattern_iarg_add) added otherwise a string argument
1132 is added. At present there's no way to add a binary data argument.
1133 */
1134 (pattern, mode, vtype, value))
1135 {
1136 Tt_pattern p = unbox_tooltalk_pattern (pattern);
1137 Tt_mode n;
1138
1139 CHECK_STRING (vtype);
1140 CHECK_TOOLTALK_CONSTANT (mode);
1141
1142 n = (Tt_mode) tooltalk_constant_value (mode);
1143
1144 if (!VALID_TOOLTALK_PATTERNP (p))
1145 return Qnil;
1146
1147 {
1148 CONST char *vtype_ext;
1149
1150 GET_C_STRING_OS_DATA_ALLOCA (vtype, vtype_ext);
1151 if (NILP (value))
1152 tt_pattern_arg_add (p, n, vtype_ext, NULL);
1153 else if (STRINGP (value))
1154 {
1155 CONST char *value_ext;
1156 GET_C_STRING_OS_DATA_ALLOCA (value, value_ext);
1157 tt_pattern_arg_add (p, n, vtype_ext, value_ext);
1158 }
1159 else if (INTP (value))
1160 tt_pattern_iarg_add (p, n, vtype_ext, XINT (value));
1161 }
1162
1163 return Qnil;
1164 }
1165
1166
1167 DEFUN ("register-tooltalk-pattern", Fregister_tooltalk_pattern, 1, 1, 0, /*
1168 Emacs will begin receiving messages that match this pattern.
1169 */
1170 (pattern))
1171 {
1172 Tt_pattern p = unbox_tooltalk_pattern (pattern);
1173
1174 if (VALID_TOOLTALK_PATTERNP (p) && tt_pattern_register (p) == TT_OK)
1175 {
1176 Fputhash (pattern, Qnil, Vtooltalk_pattern_gcpro);
1177 return Qt;
1178 }
1179 else
1180 return Qnil;
1181 }
1182
1183
1184 DEFUN ("unregister-tooltalk-pattern", Funregister_tooltalk_pattern, 1, 1, 0, /*
1185 Emacs will stop receiving messages that match this pattern.
1186 */
1187 (pattern))
1188 {
1189 Tt_pattern p = unbox_tooltalk_pattern (pattern);
1190
1191 if (VALID_TOOLTALK_PATTERNP (p))
1192 {
1193 tt_pattern_unregister (p);
1194 Fremhash (pattern, Vtooltalk_pattern_gcpro);
1195 }
1196
1197 return Qnil;
1198 }
1199
1200
1201 DEFUN ("tooltalk-pattern-prop-get", Ftooltalk_pattern_prop_get, 2, 2, 0, /*
1202 Return the value of PROPERTY in tooltalk pattern PATTERN.
1203 This is the last value set with `tooltalk-pattern-prop-set'.
1204 */
1205 (pattern, property))
1206 {
1207 CHECK_TOOLTALK_PATTERN (pattern);
1208 return Fget (XTOOLTALK_PATTERN (pattern)->plist_sym, property, Qnil);
1209 }
1210
1211
1212 DEFUN ("tooltalk-pattern-prop-set", Ftooltalk_pattern_prop_set, 3, 3, 0, /*
1213 Set the value of PROPERTY to VALUE in tooltalk pattern PATTERN.
1214 It can be retrieved with `tooltalk-pattern-prop-get'.
1215 */
1216 (pattern, property, value))
1217 {
1218 CHECK_TOOLTALK_PATTERN (pattern);
1219 return Fput (XTOOLTALK_PATTERN (pattern)->plist_sym, property, value);
1220 }
1221
1222
1223 DEFUN ("tooltalk-pattern-plist-get", Ftooltalk_pattern_plist_get, 1, 1, 0, /*
1224 Return the a list of all the properties currently set in PATTERN.
1225 */
1226 (pattern))
1227 {
1228 CHECK_TOOLTALK_PATTERN (pattern);
1229 return
1230 Fcopy_sequence (Fsymbol_plist (XTOOLTALK_PATTERN (pattern)->plist_sym));
1231 }
1232
1233 DEFUN ("tooltalk-default-procid", Ftooltalk_default_procid, 0, 0, 0, /*
1234 Return current default process identifier for your process.
1235 */
1236 ())
1237 {
1238 char *procid = tt_default_procid ();
1239 return procid ? build_string (procid) : Qnil;
1240 }
1241
1242 DEFUN ("tooltalk-default-session", Ftooltalk_default_session, 0, 0, 0, /*
1243 Return current default session identifier for the current default procid.
1244 */
1245 ())
1246 {
1247 char *session = tt_default_session ();
1248 return session ? build_string (session) : Qnil;
1249 }
1250
1251 static void
1252 init_tooltalk (void)
1253 {
1254 /* This function can GC */
1255 char *retval;
1256 Lisp_Object lp;
1257 Lisp_Object fil;
1258
1259
1260 /* tt_open() messes with our signal handler flags (at least when no
1261 ttsessions is running on the machine), therefore we save the
1262 actions and restore them after the call */
1263 #ifdef HAVE_SIGPROCMASK
1264 {
1265 struct sigaction ActSIGQUIT;
1266 struct sigaction ActSIGINT;
1267 struct sigaction ActSIGCHLD;
1268 sigaction (SIGQUIT, NULL, &ActSIGQUIT);
1269 sigaction (SIGINT, NULL, &ActSIGINT);
1270 sigaction (SIGCHLD, NULL, &ActSIGCHLD);
1271 #endif
1272 retval = tt_open ();
1273 #ifdef HAVE_SIGPROCMASK
1274 sigaction (SIGQUIT, &ActSIGQUIT, NULL);
1275 sigaction (SIGINT, &ActSIGINT, NULL);
1276 sigaction (SIGCHLD, &ActSIGCHLD, NULL);
1277 }
1278 #endif
1279
1280
1281 if (tt_ptr_error (retval) != TT_OK)
1282 return;
1283
1284 Vtooltalk_fd = make_int (tt_fd ());
1285
1286 tt_session_join (tt_default_session ());
1287
1288 lp = connect_to_file_descriptor (build_string ("tooltalk"), Qnil,
1289 Vtooltalk_fd, Vtooltalk_fd);
1290 if (!NILP (lp))
1291 {
1292 /* Don't ask the user for confirmation when exiting Emacs */
1293 Fprocess_kill_without_query (lp, Qnil);
1294 XSETSUBR (fil, &SFreceive_tooltalk_message);
1295 set_process_filter (lp, fil, 1);
1296 }
1297 else
1298 {
1299 tt_close ();
1300 Vtooltalk_fd = Qnil;
1301 return;
1302 }
1303
1304 #if defined (SOLARIS2)
1305 /* Apparently the tt_message_send_on_exit() function does not exist
1306 under SunOS 4.x or IRIX 5 or various other non-Solaris-2 systems.
1307 No big deal if we don't do the following under those systems. */
1308 {
1309 Tt_message exit_msg = tt_message_create ();
1310
1311 tt_message_op_set (exit_msg, "emacs-aborted");
1312 tt_message_scope_set (exit_msg, TT_SESSION);
1313 tt_message_class_set (exit_msg, TT_NOTICE);
1314 tt_message_send_on_exit (exit_msg);
1315 tt_message_destroy (exit_msg);
1316 }
1317 #endif
1318 }
1319
1320 DEFUN ("tooltalk-open-connection", Ftooltalk_open_connection, 0, 0, 0, /*
1321 Opens a connection to the ToolTalk server.
1322 Returns t if successful, nil otherwise.
1323 */
1324 ())
1325 {
1326 if (!NILP (Vtooltalk_fd))
1327 error ("Already connected to ToolTalk.");
1328 if (noninteractive)
1329 error ("Can't connect to ToolTalk in batch mode.");
1330 init_tooltalk ();
1331 return NILP (Vtooltalk_fd) ? Qnil : Qt;
1332 }
1333
1334
1335 void
1336 syms_of_tooltalk (void)
1337 {
1338 defsymbol (&Qtooltalk_messagep, "tooltalk-message-p");
1339 DEFSUBR (Ftooltalk_message_p);
1340 defsymbol (&Qtooltalk_patternp, "tooltalk-pattern-p");
1341 DEFSUBR (Ftooltalk_pattern_p);
1342 defsymbol (&Qtooltalk_message_handler_hook, "tooltalk-message-handler-hook");
1343 defsymbol (&Qtooltalk_pattern_handler_hook, "tooltalk-pattern-handler-hook");
1344 defsymbol (&Qtooltalk_unprocessed_message_hook,
1345 "tooltalk-unprocessed-message-hook");
1346
1347 DEFSUBR (Freceive_tooltalk_message);
1348 DEFSUBR (Fcreate_tooltalk_message);
1349 DEFSUBR (Fdestroy_tooltalk_message);
1350 DEFSUBR (Fadd_tooltalk_message_arg);
1351 DEFSUBR (Fget_tooltalk_message_attribute);
1352 DEFSUBR (Fset_tooltalk_message_attribute);
1353 DEFSUBR (Fsend_tooltalk_message);
1354 DEFSUBR (Freturn_tooltalk_message);
1355 DEFSUBR (Fcreate_tooltalk_pattern);
1356 DEFSUBR (Fdestroy_tooltalk_pattern);
1357 DEFSUBR (Fadd_tooltalk_pattern_attribute);
1358 DEFSUBR (Fadd_tooltalk_pattern_arg);
1359 DEFSUBR (Fregister_tooltalk_pattern);
1360 DEFSUBR (Funregister_tooltalk_pattern);
1361 DEFSUBR (Ftooltalk_pattern_plist_get);
1362 DEFSUBR (Ftooltalk_pattern_prop_set);
1363 DEFSUBR (Ftooltalk_pattern_prop_get);
1364 DEFSUBR (Ftooltalk_default_procid);
1365 DEFSUBR (Ftooltalk_default_session);
1366 DEFSUBR (Ftooltalk_open_connection);
1367
1368 defsymbol (&Qreceive_tooltalk_message, "receive-tooltalk-message");
1369 defsymbol (&Qtt_address, "address");
1370 defsymbol (&Qtt_args_count, "args_count");
1371 defsymbol (&Qtt_arg_bval, "arg_bval");
1372 defsymbol (&Qtt_arg_ival, "arg_ival");
1373 defsymbol (&Qtt_arg_mode, "arg_mode");
1374 defsymbol (&Qtt_arg_type, "arg_type");
1375 defsymbol (&Qtt_arg_val, "arg_val");
1376 defsymbol (&Qtt_class, "class");
1377 defsymbol (&Qtt_category, "category");
1378 defsymbol (&Qtt_disposition, "disposition");
1379 defsymbol (&Qtt_file, "file");
1380 defsymbol (&Qtt_gid, "gid");
1381 defsymbol (&Qtt_handler, "handler");
1382 defsymbol (&Qtt_handler_ptype, "handler_ptype");
1383 defsymbol (&Qtt_object, "object");
1384 defsymbol (&Qtt_op, "op");
1385 defsymbol (&Qtt_opnum, "opnum");
1386 defsymbol (&Qtt_otype, "otype");
1387 defsymbol (&Qtt_scope, "scope");
1388 defsymbol (&Qtt_sender, "sender");
1389 defsymbol (&Qtt_sender_ptype, "sender_ptype");
1390 defsymbol (&Qtt_session, "session");
1391 defsymbol (&Qtt_state, "state");
1392 defsymbol (&Qtt_status, "status");
1393 defsymbol (&Qtt_status_string, "status_string");
1394 defsymbol (&Qtt_uid, "uid");
1395 defsymbol (&Qtt_callback, "callback");
1396 defsymbol (&Qtt_prop, "prop");
1397 defsymbol (&Qtt_plist, "plist");
1398 defsymbol (&Qtt_reject, "reject");
1399 defsymbol (&Qtt_reply, "reply");
1400 defsymbol (&Qtt_fail, "fail");
1401
1402 deferror (&Qtooltalk_error, "tooltalk-error", "ToolTalk error", Qio_error);
1403 }
1404
1405 void
1406 vars_of_tooltalk (void)
1407 {
1408 Fprovide (intern ("tooltalk"));
1409
1410 DEFVAR_LISP ("tooltalk-fd", &Vtooltalk_fd /*
1411 File descriptor returned by tt_initialize; nil if not connected to ToolTalk.
1412 */ );
1413 Vtooltalk_fd = Qnil;
1414
1415 DEFVAR_LISP ("tooltalk-message-handler-hook",
1416 &Vtooltalk_message_handler_hook /*
1417 List of functions to be applied to each ToolTalk message reply received.
1418 This will always occur as a result of our sending a request message.
1419 Functions will be called with two arguments, the message and the
1420 corresponding pattern. This hook will not be called if the request
1421 message was created without a C-level callback function (see
1422 `tooltalk-unprocessed-message-hook').
1423 */ );
1424 Vtooltalk_message_handler_hook = Qnil;
1425
1426 DEFVAR_LISP ("tooltalk-pattern-handler-hook",
1427 &Vtooltalk_pattern_handler_hook /*
1428 List of functions to be applied to each pattern-matching ToolTalk message.
1429 This is all messages except those handled by `tooltalk-message-handler-hook'.
1430 Functions will be called with two arguments, the message and the
1431 corresponding pattern.
1432 */ );
1433 Vtooltalk_pattern_handler_hook = Qnil;
1434
1435 DEFVAR_LISP ("tooltalk-unprocessed-message-hook",
1436 &Vtooltalk_unprocessed_message_hook /*
1437 List of functions to be applied to each unprocessed ToolTalk message.
1438 Unprocessed messages are messages that didn't match any patterns.
1439 */ );
1440 Vtooltalk_unprocessed_message_hook = Qnil;
1441
1442 Tooltalk_Message_plist_str = build_string ("Tooltalk Message plist");
1443 Tooltalk_Pattern_plist_str = build_string ("Tooltalk Pattern p plist");
1444
1445 staticpro(&Tooltalk_Message_plist_str);
1446 staticpro(&Tooltalk_Pattern_plist_str);
1447
1448 #define MAKE_CONSTANT(name) do { \
1449 defsymbol (&Q_ ## name, #name); \
1450 Fset (Q_ ## name, make_int (name)); \
1451 } while (0)
1452
1453 MAKE_CONSTANT (TT_MODE_UNDEFINED);
1454 MAKE_CONSTANT (TT_IN);
1455 MAKE_CONSTANT (TT_OUT);
1456 MAKE_CONSTANT (TT_INOUT);
1457 MAKE_CONSTANT (TT_MODE_LAST);
1458
1459 MAKE_CONSTANT (TT_SCOPE_NONE);
1460 MAKE_CONSTANT (TT_SESSION);
1461 MAKE_CONSTANT (TT_FILE);
1462 MAKE_CONSTANT (TT_BOTH);
1463 MAKE_CONSTANT (TT_FILE_IN_SESSION);
1464
1465 MAKE_CONSTANT (TT_CLASS_UNDEFINED);
1466 MAKE_CONSTANT (TT_NOTICE);
1467 MAKE_CONSTANT (TT_REQUEST);
1468 MAKE_CONSTANT (TT_CLASS_LAST);
1469
1470 MAKE_CONSTANT (TT_CATEGORY_UNDEFINED);
1471 MAKE_CONSTANT (TT_OBSERVE);
1472 MAKE_CONSTANT (TT_HANDLE);
1473 MAKE_CONSTANT (TT_CATEGORY_LAST);
1474
1475 MAKE_CONSTANT (TT_PROCEDURE);
1476 MAKE_CONSTANT (TT_OBJECT);
1477 MAKE_CONSTANT (TT_HANDLER);
1478 MAKE_CONSTANT (TT_OTYPE);
1479 MAKE_CONSTANT (TT_ADDRESS_LAST);
1480
1481 MAKE_CONSTANT (TT_CREATED);
1482 MAKE_CONSTANT (TT_SENT);
1483 MAKE_CONSTANT (TT_HANDLED);
1484 MAKE_CONSTANT (TT_FAILED);
1485 MAKE_CONSTANT (TT_QUEUED);
1486 MAKE_CONSTANT (TT_STARTED);
1487 MAKE_CONSTANT (TT_REJECTED);
1488 MAKE_CONSTANT (TT_STATE_LAST);
1489
1490 MAKE_CONSTANT (TT_DISCARD);
1491 MAKE_CONSTANT (TT_QUEUE);
1492 MAKE_CONSTANT (TT_START);
1493
1494 #undef MAKE_CONSTANT
1495
1496 staticpro (&Vtooltalk_message_gcpro);
1497 staticpro (&Vtooltalk_pattern_gcpro);
1498 Vtooltalk_message_gcpro =
1499 make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
1500 Vtooltalk_pattern_gcpro =
1501 make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
1502 }