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