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