Mercurial > hg > xemacs-beta
annotate src/tooltalk.c @ 5724:ede80ef92a74
Make soft links in src for module source files, if built in to the executable.
This ensures that those files are built with the same compiler flags as all
other source files.
See these xemacs-beta messages:
<CAHCOHQn+q=Xuwq+y68dvqi7afAP9f-TdB7=8YiZ8VYO816sjHg@mail.gmail.com>
<f5by5ejqiyk.fsf@calexico.inf.ed.ac.uk>
| author | Jerry James <james@xemacs.org> |
|---|---|
| date | Sat, 02 Mar 2013 14:32:37 -0700 |
| 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 } |