Mercurial > hg > xemacs-beta

comparison src/tooltalk.c @ 0:376386a54a3c r19-14

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