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