Mercurial > hg > xemacs-beta
annotate src/tooltalk.c @ 4981:4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
-------------------- ChangeLog entries follow: --------------------
modules/ChangeLog addition:
2010-02-05 Ben Wing <ben@xemacs.org>
* postgresql/postgresql.c:
* postgresql/postgresql.c (CHECK_LIVE_CONNECTION):
* postgresql/postgresql.c (Fpq_connectdb):
* postgresql/postgresql.c (Fpq_connect_start):
* postgresql/postgresql.c (Fpq_lo_import):
* postgresql/postgresql.c (Fpq_lo_export):
* ldap/eldap.c (Fldap_open):
* ldap/eldap.c (Fldap_search_basic):
* ldap/eldap.c (Fldap_add):
* ldap/eldap.c (Fldap_modify):
* ldap/eldap.c (Fldap_delete):
* canna/canna_api.c (Fcanna_initialize):
* canna/canna_api.c (Fcanna_store_yomi):
* canna/canna_api.c (Fcanna_parse):
* canna/canna_api.c (Fcanna_henkan_begin):
EXTERNAL_TO_C_STRING returns its argument instead of storing it
in a parameter, and is renamed to EXTERNAL_TO_ITEXT. Similar
things happen to related macros. See entry in src/ChangeLog.
More Mule-izing of postgresql.c. Extract out common code
between `pq-connectdb' and `pq-connect-start'. Fix places
that signal an error string using a formatted string to instead
follow the standard and have a fixed reason followed by the
particular error message stored as one of the frobs.
src/ChangeLog addition:
2010-02-05 Ben Wing <ben@xemacs.org>
* console-msw.c (write_string_to_mswindows_debugging_output):
* console-msw.c (Fmswindows_message_box):
* console-x.c (x_perhaps_init_unseen_key_defaults):
* console.c:
* database.c (dbm_get):
* database.c (dbm_put):
* database.c (dbm_remove):
* database.c (berkdb_get):
* database.c (berkdb_put):
* database.c (berkdb_remove):
* database.c (Fopen_database):
* device-gtk.c (gtk_init_device):
* device-msw.c (msprinter_init_device_internal):
* device-msw.c (msprinter_default_printer):
* device-msw.c (msprinter_init_device):
* device-msw.c (sync_printer_with_devmode):
* device-msw.c (Fmsprinter_select_settings):
* device-x.c (sanity_check_geometry_resource):
* device-x.c (Dynarr_add_validified_lisp_string):
* device-x.c (x_init_device):
* device-x.c (Fx_put_resource):
* device-x.c (Fx_valid_keysym_name_p):
* device-x.c (Fx_set_font_path):
* dialog-msw.c (push_lisp_string_as_unicode):
* dialog-msw.c (handle_directory_dialog_box):
* dialog-msw.c (handle_file_dialog_box):
* dialog-x.c (dbox_descriptor_to_widget_value):
* editfns.c (Fformat_time_string):
* editfns.c (Fencode_time):
* editfns.c (Fset_time_zone_rule):
* emacs.c (make_argc_argv):
* emacs.c (Fdump_emacs):
* emodules.c (emodules_load):
* eval.c:
* eval.c (maybe_signal_error_1):
* event-msw.c (Fdde_alloc_advise_item):
* event-msw.c (mswindows_dde_callback):
* event-msw.c (mswindows_wnd_proc):
* fileio.c (report_error_with_errno):
* fileio.c (Fsysnetunam):
* fileio.c (Fdo_auto_save):
* font-mgr.c (extract_fcapi_string):
* font-mgr.c (Ffc_config_app_font_add_file):
* font-mgr.c (Ffc_config_app_font_add_dir):
* font-mgr.c (Ffc_config_filename):
* frame-gtk.c (gtk_set_frame_text_value):
* frame-gtk.c (gtk_create_widgets):
* frame-msw.c (mswindows_init_frame_1):
* frame-msw.c (mswindows_set_title_from_ibyte):
* frame-msw.c (msprinter_init_frame_3):
* frame-x.c (x_set_frame_text_value):
* frame-x.c (x_set_frame_properties):
* frame-x.c (start_drag_internal_1):
* frame-x.c (x_cde_transfer_callback):
* frame-x.c (x_create_widgets):
* glyphs-eimage.c (my_jpeg_output_message):
* glyphs-eimage.c (jpeg_instantiate):
* glyphs-eimage.c (gif_instantiate):
* glyphs-eimage.c (png_instantiate):
* glyphs-eimage.c (tiff_instantiate):
* glyphs-gtk.c (xbm_instantiate_1):
* glyphs-gtk.c (gtk_xbm_instantiate):
* glyphs-gtk.c (gtk_xpm_instantiate):
* glyphs-gtk.c (gtk_xface_instantiate):
* glyphs-gtk.c (cursor_font_instantiate):
* glyphs-gtk.c (gtk_redisplay_widget):
* glyphs-gtk.c (gtk_widget_instantiate_1):
* glyphs-gtk.c (gtk_add_tab_item):
* glyphs-msw.c (mswindows_xpm_instantiate):
* glyphs-msw.c (bmp_instantiate):
* glyphs-msw.c (mswindows_resource_instantiate):
* glyphs-msw.c (xbm_instantiate_1):
* glyphs-msw.c (mswindows_xbm_instantiate):
* glyphs-msw.c (mswindows_xface_instantiate):
* glyphs-msw.c (mswindows_redisplay_widget):
* glyphs-msw.c (mswindows_widget_instantiate):
* glyphs-msw.c (add_tree_item):
* glyphs-msw.c (add_tab_item):
* glyphs-msw.c (mswindows_combo_box_instantiate):
* glyphs-msw.c (mswindows_widget_query_string_geometry):
* glyphs-x.c (x_locate_pixmap_file):
* glyphs-x.c (xbm_instantiate_1):
* glyphs-x.c (x_xbm_instantiate):
* glyphs-x.c (extract_xpm_color_names):
* glyphs-x.c (x_xpm_instantiate):
* glyphs-x.c (x_xface_instantiate):
* glyphs-x.c (autodetect_instantiate):
* glyphs-x.c (safe_XLoadFont):
* glyphs-x.c (cursor_font_instantiate):
* glyphs-x.c (x_redisplay_widget):
* glyphs-x.c (Fchange_subwindow_property):
* glyphs-x.c (x_widget_instantiate):
* glyphs-x.c (x_tab_control_redisplay):
* glyphs.c (pixmap_to_lisp_data):
* gui-x.c (menu_separator_style_and_to_external):
* gui-x.c (add_accel_and_to_external):
* gui-x.c (button_item_to_widget_value):
* hpplay.c (player_error_internal):
* hpplay.c (play_sound_file):
* hpplay.c (play_sound_data):
* intl.c (Fset_current_locale):
* lisp.h:
* menubar-gtk.c (gtk_xemacs_set_accel_keys):
* menubar-msw.c (populate_menu_add_item):
* menubar-msw.c (populate_or_checksum_helper):
* menubar-x.c (menu_item_descriptor_to_widget_value_1):
* nt.c (init_user_info):
* nt.c (get_long_basename):
* nt.c (nt_get_resource):
* nt.c (init_mswindows_environment):
* nt.c (get_cached_volume_information):
* nt.c (mswindows_readdir):
* nt.c (read_unc_volume):
* nt.c (mswindows_stat):
* nt.c (mswindows_getdcwd):
* nt.c (mswindows_executable_type):
* nt.c (Fmswindows_short_file_name):
* ntplay.c (nt_play_sound_file):
* objects-gtk.c:
* objects-gtk.c (gtk_valid_color_name_p):
* objects-gtk.c (gtk_initialize_font_instance):
* objects-gtk.c (gtk_font_list):
* objects-msw.c (font_enum_callback_2):
* objects-msw.c (parse_font_spec):
* objects-x.c (x_parse_nearest_color):
* objects-x.c (x_valid_color_name_p):
* objects-x.c (x_initialize_font_instance):
* objects-x.c (x_font_instance_truename):
* objects-x.c (x_font_list):
* objects-xlike-inc.c (XFUN):
* objects-xlike-inc.c (xft_find_charset_font):
* process-nt.c (mswindows_report_winsock_error):
* process-nt.c (nt_create_process):
* process-nt.c (get_internet_address):
* process-nt.c (nt_open_network_stream):
* process-unix.c:
* process-unix.c (allocate_pty):
* process-unix.c (get_internet_address):
* process-unix.c (unix_canonicalize_host_name):
* process-unix.c (unix_open_network_stream):
* realpath.c:
* select-common.h (lisp_data_to_selection_data):
* select-gtk.c (symbol_to_gtk_atom):
* select-gtk.c (atom_to_symbol):
* select-msw.c (symbol_to_ms_cf):
* select-msw.c (mswindows_register_selection_data_type):
* select-x.c (symbol_to_x_atom):
* select-x.c (x_atom_to_symbol):
* select-x.c (hack_motif_clipboard_selection):
* select-x.c (Fx_store_cutbuffer_internal):
* sound.c (Fplay_sound_file):
* sound.c (Fplay_sound):
* sound.h (sound_perror):
* sysdep.c:
* sysdep.c (qxe_allocating_getcwd):
* sysdep.c (qxe_execve):
* sysdep.c (copy_in_passwd):
* sysdep.c (qxe_getpwnam):
* sysdep.c (qxe_ctime):
* sysdll.c (dll_open):
* sysdll.c (dll_function):
* sysdll.c (dll_variable):
* sysdll.c (search_linked_libs):
* sysdll.c (dll_error):
* sysfile.h:
* sysfile.h (PATHNAME_CONVERT_OUT_TSTR):
* sysfile.h (PATHNAME_CONVERT_OUT_UTF_8):
* sysfile.h (PATHNAME_CONVERT_OUT):
* sysfile.h (LISP_PATHNAME_CONVERT_OUT):
* syswindows.h (ITEXT_TO_TSTR):
* syswindows.h (LOCAL_FILE_FORMAT_TO_TSTR):
* syswindows.h (TSTR_TO_LOCAL_FILE_FORMAT):
* syswindows.h (LOCAL_FILE_FORMAT_TO_INTERNAL_MSWIN):
* syswindows.h (LISP_LOCAL_FILE_FORMAT_MAYBE_URL_TO_TSTR):
* text.h:
* text.h (eicpy_ext_len):
* text.h (enum new_dfc_src_type):
* text.h (EXTERNAL_TO_ITEXT):
* text.h (GET_STRERROR):
* tooltalk.c (check_status):
* tooltalk.c (Fadd_tooltalk_message_arg):
* tooltalk.c (Fadd_tooltalk_pattern_attribute):
* tooltalk.c (Fadd_tooltalk_pattern_arg):
* win32.c (tstr_to_local_file_format):
* win32.c (mswindows_lisp_error_1):
* win32.c (mswindows_report_process_error):
* win32.c (Fmswindows_shell_execute):
* win32.c (mswindows_read_link_1):
Changes involving external/internal format conversion,
mostly code cleanup and renaming.
1. Eliminate the previous macros like LISP_STRING_TO_EXTERNAL
that stored its result in a parameter. The new version of
LISP_STRING_TO_EXTERNAL returns its result through the
return value, same as the previous NEW_LISP_STRING_TO_EXTERNAL.
Use the new-style macros throughout the code.
2. Rename C_STRING_TO_EXTERNAL and friends to ITEXT_TO_EXTERNAL,
in keeping with overall naming rationalization involving
Itext and related types.
Macros involved in previous two:
EXTERNAL_TO_C_STRING -> EXTERNAL_TO_ITEXT
EXTERNAL_TO_C_STRING_MALLOC -> EXTERNAL_TO_ITEXT_MALLOC
SIZED_EXTERNAL_TO_C_STRING -> SIZED_EXTERNAL_TO_ITEXT
SIZED_EXTERNAL_TO_C_STRING_MALLOC -> SIZED_EXTERNAL_TO_ITEXT_MALLOC
C_STRING_TO_EXTERNAL -> ITEXT_TO_EXTERNAL
C_STRING_TO_EXTERNAL_MALLOC -> ITEXT_TO_EXTERNAL_MALLOC
LISP_STRING_TO_EXTERNAL
LISP_STRING_TO_EXTERNAL_MALLOC
LISP_STRING_TO_TSTR
C_STRING_TO_TSTR -> ITEXT_TO_TSTR
TSTR_TO_C_STRING -> TSTR_TO_ITEXT
The following four still return their values through parameters,
since they have more than one value to return:
C_STRING_TO_SIZED_EXTERNAL -> ITEXT_TO_SIZED_EXTERNAL
LISP_STRING_TO_SIZED_EXTERNAL
C_STRING_TO_SIZED_EXTERNAL_MALLOC -> ITEXT_TO_SIZED_EXTERNAL_MALLOC
LISP_STRING_TO_SIZED_EXTERNAL_MALLOC
Sometimes additional casts had to be inserted, since the old
macros played strange games and completely defeated the type system
of the store params.
3. Rewrite many places where direct calls to TO_EXTERNAL_FORMAT
occurred with calls to one of the convenience macros listed above,
or to make_extstring().
4. Eliminate SIZED_C_STRING macros (they were hardly used, anyway)
and use a direct call to TO_EXTERNAL_FORMAT or TO_INTERNAL_FORMAT.
4. Use LISP_PATHNAME_CONVERT_OUT in many places instead of something
like LISP_STRING_TO_EXTERNAL(..., Qfile_name).
5. Eliminate some temporary variables that are no longer necessary
now that we return a value rather than storing it into a variable.
6. Some Mule-izing in database.c.
7. Error functions:
-- A bit of code cleanup in maybe_signal_error_1.
-- Eliminate report_file_type_error; it's just an alias for
signal_error_2 with params in a different order.
-- Fix some places in the hostname-handling code that directly
inserted externally-retrieved error strings into the
supposed ASCII "reason" param instead of doing the right thing
and sticking text descriptive of what was going on in "reason"
and putting the external message in a frob.
8. Use Ascbyte instead of CIbyte in process-unix.c and maybe one
or two other places.
9. Some code cleanup in copy_in_passwd() in sysdep.c.
10. Fix a real bug due to accidental variable shadowing in
tstr_to_local_file_format() in win32.c.
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Fri, 05 Feb 2010 11:02:24 -0600 |
| parents | 304aebb79cd3 |
| children | ae48681c47fa |
| 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 { | |
| 3017 | 150 struct LCRECORD_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) | |
| 4846 | 175 printing_unreadable_lcrecord (obj, 0); |
| 428 | 176 |
| 4846 | 177 write_fmt_string (printcharfun, "#<tooltalk-message id:0x%lx 0x%x>", |
| 800 | 178 (long) (p->m), p->header.uid); |
| 428 | 179 } |
| 180 | |
| 934 | 181 DEFINE_LRECORD_IMPLEMENTATION ("tooltalk-message", tooltalk_message, |
| 960 | 182 0, /*dumpable-flag*/ |
| 934 | 183 mark_tooltalk_message, print_tooltalk_message, |
| 184 0, 0, 0, | |
| 185 tooltalk_message_description, | |
| 186 Lisp_Tooltalk_Message); | |
| 428 | 187 |
| 188 static Lisp_Object | |
| 189 make_tooltalk_message (Tt_message m) | |
| 190 { | |
| 191 Lisp_Object val; | |
| 440 | 192 Lisp_Tooltalk_Message *msg = |
| 3017 | 193 ALLOC_LCRECORD_TYPE (Lisp_Tooltalk_Message, &lrecord_tooltalk_message); |
| 428 | 194 |
| 195 msg->m = m; | |
| 196 msg->callback = Qnil; | |
| 197 msg->plist_sym = Fmake_symbol (Tooltalk_Message_plist_str); | |
| 793 | 198 return wrap_tooltalk_message (msg); |
| 428 | 199 } |
| 200 | |
| 201 Tt_message | |
| 202 unbox_tooltalk_message (Lisp_Object msg) | |
| 203 { | |
| 204 CHECK_TOOLTALK_MESSAGE (msg); | |
| 205 return XTOOLTALK_MESSAGE (msg)->m; | |
| 206 } | |
| 207 | |
| 208 DEFUN ("tooltalk-message-p", Ftooltalk_message_p, 1, 1, 0, /* | |
| 209 Return non-nil if OBJECT is a tooltalk message. | |
| 210 */ | |
| 211 (object)) | |
| 212 { | |
| 213 return TOOLTALK_MESSAGEP (object) ? Qt : Qnil; | |
| 214 } | |
| 215 | |
| 216 | |
| 217 | |
| 218 | |
| 219 /* */ | |
| 220 /* machinery for tooltalk-pattern type */ | |
| 221 /* */ | |
| 222 | |
| 223 Lisp_Object Qtooltalk_patternp; | |
| 224 | |
| 225 struct Lisp_Tooltalk_Pattern | |
| 226 { | |
| 3017 | 227 struct LCRECORD_HEADER header; |
| 428 | 228 Lisp_Object plist_sym, callback; |
| 229 Tt_pattern p; | |
| 230 }; | |
| 231 | |
| 1204 | 232 static const struct memory_description tooltalk_pattern_description [] = { |
| 934 | 233 { XD_LISP_OBJECT, offsetof (struct Lisp_Tooltalk_Pattern, callback) }, |
| 234 { XD_LISP_OBJECT, offsetof (struct Lisp_Tooltalk_Pattern, plist_sym) }, | |
| 235 { XD_END } | |
| 236 }; | |
| 237 | |
| 428 | 238 static Lisp_Object |
| 239 mark_tooltalk_pattern (Lisp_Object obj) | |
| 240 { | |
| 241 mark_object (XTOOLTALK_PATTERN (obj)->callback); | |
| 242 return XTOOLTALK_PATTERN (obj)->plist_sym; | |
| 243 } | |
| 244 | |
| 245 static void | |
| 246 print_tooltalk_pattern (Lisp_Object obj, Lisp_Object printcharfun, | |
| 2286 | 247 int UNUSED (escapeflag)) |
| 428 | 248 { |
| 440 | 249 Lisp_Tooltalk_Pattern *p = XTOOLTALK_PATTERN (obj); |
| 428 | 250 |
| 251 if (print_readably) | |
| 4846 | 252 printing_unreadable_lcrecord (obj, 0); |
| 428 | 253 |
| 4846 | 254 write_fmt_string (printcharfun, "#<tooltalk-pattern id:0x%lx 0x%x>", |
| 800 | 255 (long) (p->p), p->header.uid); |
| 428 | 256 } |
| 257 | |
| 934 | 258 DEFINE_LRECORD_IMPLEMENTATION ("tooltalk-pattern", tooltalk_pattern, |
| 960 | 259 0, /*dumpable-flag*/ |
| 934 | 260 mark_tooltalk_pattern, print_tooltalk_pattern, |
| 261 0, 0, 0, | |
| 262 tooltalk_pattern_description, | |
| 263 Lisp_Tooltalk_Pattern); | |
| 428 | 264 |
| 265 static Lisp_Object | |
| 266 make_tooltalk_pattern (Tt_pattern p) | |
| 267 { | |
| 440 | 268 Lisp_Tooltalk_Pattern *pat = |
| 3017 | 269 ALLOC_LCRECORD_TYPE (Lisp_Tooltalk_Pattern, &lrecord_tooltalk_pattern); |
| 428 | 270 Lisp_Object val; |
| 271 | |
| 272 pat->p = p; | |
| 273 pat->callback = Qnil; | |
| 274 pat->plist_sym = Fmake_symbol (Tooltalk_Pattern_plist_str); | |
| 275 | |
| 793 | 276 return wrap_tooltalk_pattern (pat); |
| 428 | 277 } |
| 278 | |
| 279 static Tt_pattern | |
| 280 unbox_tooltalk_pattern (Lisp_Object pattern) | |
| 281 { | |
| 282 CHECK_TOOLTALK_PATTERN (pattern); | |
| 283 return XTOOLTALK_PATTERN (pattern)->p; | |
| 284 } | |
| 285 | |
| 286 DEFUN ("tooltalk-pattern-p", Ftooltalk_pattern_p, 1, 1, 0, /* | |
| 287 Return non-nil if OBJECT is a tooltalk pattern. | |
| 288 */ | |
| 289 (object)) | |
| 290 { | |
| 291 return TOOLTALK_PATTERNP (object) ? Qt : Qnil; | |
| 292 } | |
| 293 | |
| 294 | |
| 295 | |
| 296 | |
| 297 static int | |
| 298 tooltalk_constant_value (Lisp_Object s) | |
| 299 { | |
| 300 if (INTP (s)) | |
| 301 return XINT (s); | |
| 302 else if (SYMBOLP (s)) | |
| 303 return XINT (XSYMBOL (s)->value); | |
| 304 else | |
| 305 return 0; /* should never occur */ | |
| 306 } | |
| 307 | |
| 308 static void | |
| 309 check_status (Tt_status st) | |
| 310 { | |
| 311 if (tt_is_err (st)) | |
| 563 | 312 { |
| 867 | 313 CIbyte *err; |
| 563 | 314 |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
315 err = EXTERNAL_TO_ITEXT (tt_status_message (st), Qtooltalk_encoding); |
| 563 | 316 signal_error (Qtooltalk_error, err, Qunbound); |
| 317 } | |
| 428 | 318 } |
| 319 | |
| 320 DEFUN ("receive-tooltalk-message", Freceive_tooltalk_message, 0, 2, 0, /* | |
| 321 Run tt_message_receive(). | |
| 322 This function is the process handler for the ToolTalk connection process. | |
| 323 */ | |
| 2286 | 324 (UNUSED (ignore1), UNUSED (ignore2))) |
| 428 | 325 { |
| 326 /* This function can GC */ | |
| 327 Tt_message mess = tt_message_receive (); | |
| 328 Lisp_Object message_ = make_tooltalk_message (mess); | |
| 329 struct gcpro gcpro1; | |
| 330 | |
| 331 GCPRO1 (message_); | |
| 332 if (mess != NULL && !NILP (Vtooltalk_unprocessed_message_hook)) | |
| 333 va_run_hook_with_args (Qtooltalk_unprocessed_message_hook, 1, message_); | |
| 334 UNGCPRO; | |
| 335 | |
| 336 /* see comment in event-stream.c about this return value. */ | |
| 337 return Qzero; | |
| 338 } | |
| 339 | |
| 340 static Tt_callback_action | |
| 341 tooltalk_message_callback (Tt_message m, Tt_pattern p) | |
| 342 { | |
| 343 /* This function can GC */ | |
| 344 Lisp_Object cb; | |
| 345 Lisp_Object message_; | |
| 346 Lisp_Object pattern; | |
| 347 struct gcpro gcpro1, gcpro2; | |
| 348 | |
| 349 #ifdef TT_DEBUG | |
| 350 int i, j; | |
| 351 | |
| 352 fprintf (tooltalk_log_file, "message_cb: %d\n", m); | |
| 353 fprintf (tooltalk_log_file, "op: %s (", tt_message_op (m)); | |
| 354 for (j = tt_message_args_count (m), i = 0; i < j; i++) { | |
| 355 fprintf (tooltalk_log_file, "%s \"%s\"", tt_message_arg_type (m, i), | |
| 356 tt_message_arg_val (m, i)); | |
| 357 fprintf (tooltalk_log_file, "%s", i == j-1 ? ")" : ", "); | |
| 358 } | |
| 359 fprintf (tooltalk_log_file, "\n\n"); | |
| 360 fflush (tooltalk_log_file); | |
| 361 #endif | |
| 362 | |
| 826 | 363 message_ = VOID_TO_LISP (tt_message_user (m, TOOLTALK_MESSAGE_KEY)); |
| 428 | 364 pattern = make_tooltalk_pattern (p); |
| 365 cb = XTOOLTALK_MESSAGE (message_)->callback; | |
| 366 GCPRO2 (message_, pattern); | |
| 367 if (!NILP (Vtooltalk_message_handler_hook)) | |
| 368 va_run_hook_with_args (Qtooltalk_message_handler_hook, 2, | |
| 369 message_, pattern); | |
| 370 | |
| 371 if ((SYMBOLP (cb) && EQ (Qt, Ffboundp (cb))) || | |
| 372 (CONSP (cb) && EQ (Qlambda, Fcar (cb)) && | |
| 373 !NILP (Flistp (Fcar (Fcdr (cb)))))) | |
| 374 call2 (cb, message_, pattern); | |
| 375 UNGCPRO; | |
| 376 | |
| 377 tt_message_destroy (m); | |
| 378 Fremhash (message_, Vtooltalk_message_gcpro); | |
| 379 | |
| 380 return TT_CALLBACK_PROCESSED; | |
| 381 } | |
| 382 | |
| 383 static Tt_callback_action | |
| 384 tooltalk_pattern_callback (Tt_message m, Tt_pattern p) | |
| 385 { | |
| 386 /* This function can GC */ | |
| 387 Lisp_Object cb; | |
| 388 Lisp_Object message_; | |
| 389 Lisp_Object pattern; | |
| 390 struct gcpro gcpro1, gcpro2; | |
| 391 | |
| 392 #ifdef TT_DEBUG | |
| 393 int i, j; | |
| 394 | |
| 395 fprintf (tooltalk_log_file, "pattern_cb: %d\n", m); | |
| 396 fprintf (tooltalk_log_file, "op: %s (", tt_message_op (m)); | |
| 397 for (j = tt_message_args_count (m), i = 0; i < j; i++) { | |
| 398 fprintf (tooltalk_log_file, "%s \"%s\"", tt_message_arg_type (m, i), | |
| 399 tt_message_arg_val (m, i)); | |
| 400 fprintf (tooltalk_log_file, "%s", i == j-1 ? ")" : ", "); | |
| 401 } | |
| 402 fprintf (tooltalk_log_file, "\n\n"); | |
| 403 fflush (tooltalk_log_file); | |
| 404 #endif | |
| 405 | |
| 406 message_ = make_tooltalk_message (m); | |
| 826 | 407 pattern = VOID_TO_LISP (tt_pattern_user (p, TOOLTALK_PATTERN_KEY)); |
| 428 | 408 cb = XTOOLTALK_PATTERN (pattern)->callback; |
| 409 GCPRO2 (message_, pattern); | |
| 410 if (!NILP (Vtooltalk_pattern_handler_hook)) | |
| 411 va_run_hook_with_args (Qtooltalk_pattern_handler_hook, 2, | |
| 412 message_, pattern); | |
| 413 | |
| 414 if (SYMBOLP (cb) && EQ (Qt, Ffboundp (cb))) | |
| 415 call2 (cb, message_, pattern); | |
| 416 UNGCPRO; | |
| 417 | |
| 418 tt_message_destroy (m); | |
| 419 return TT_CALLBACK_PROCESSED; | |
| 420 } | |
| 421 | |
| 422 static Lisp_Object | |
| 423 tt_mode_symbol (Tt_mode n) | |
| 424 { | |
| 425 switch (n) | |
| 426 { | |
| 427 case TT_MODE_UNDEFINED: return Q_TT_MODE_UNDEFINED; | |
| 428 case TT_IN: return Q_TT_IN; | |
| 429 case TT_OUT: return Q_TT_OUT; | |
| 430 case TT_INOUT: return Q_TT_INOUT; | |
| 431 case TT_MODE_LAST: return Q_TT_MODE_LAST; | |
| 432 default: return Qnil; | |
| 433 } | |
| 434 } | |
| 435 | |
| 436 static Lisp_Object | |
| 437 tt_scope_symbol (Tt_scope n) | |
| 438 { | |
| 439 switch (n) | |
| 440 { | |
| 441 case TT_SCOPE_NONE: return Q_TT_SCOPE_NONE; | |
| 442 case TT_SESSION: return Q_TT_SESSION; | |
| 443 case TT_FILE: return Q_TT_FILE; | |
| 444 case TT_BOTH: return Q_TT_BOTH; | |
| 445 case TT_FILE_IN_SESSION: return Q_TT_FILE_IN_SESSION; | |
| 446 default: return Qnil; | |
| 447 } | |
| 448 } | |
| 449 | |
| 450 | |
| 451 static Lisp_Object | |
| 452 tt_class_symbol (Tt_class n) | |
| 453 { | |
| 454 switch (n) | |
| 455 { | |
| 456 case TT_CLASS_UNDEFINED: return Q_TT_CLASS_UNDEFINED; | |
| 457 case TT_NOTICE: return Q_TT_NOTICE; | |
| 458 case TT_REQUEST: return Q_TT_REQUEST; | |
| 459 case TT_CLASS_LAST: return Q_TT_CLASS_LAST; | |
| 460 default: return Qnil; | |
| 461 } | |
| 462 } | |
| 463 | |
| 464 /* | |
| 465 * This is not being used. Is that a mistake or is this function | |
| 466 * simply not necessary? | |
| 467 */ | |
| 468 #if 0 | |
| 469 static Lisp_Object | |
| 470 tt_category_symbol (Tt_category n) | |
| 471 { | |
| 472 switch (n) | |
| 473 { | |
| 474 case TT_CATEGORY_UNDEFINED: return Q_TT_CATEGORY_UNDEFINED; | |
| 475 case TT_OBSERVE: return Q_TT_OBSERVE; | |
| 476 case TT_HANDLE: return Q_TT_HANDLE; | |
| 477 case TT_CATEGORY_LAST: return Q_TT_CATEGORY_LAST; | |
| 478 default: return Qnil; | |
| 479 } | |
| 480 } | |
| 481 #endif /* 0 */ | |
| 482 | |
| 483 static Lisp_Object | |
| 484 tt_address_symbol (Tt_address n) | |
| 485 { | |
| 486 switch (n) | |
| 487 { | |
| 488 case TT_PROCEDURE: return Q_TT_PROCEDURE; | |
| 489 case TT_OBJECT: return Q_TT_OBJECT; | |
| 490 case TT_HANDLER: return Q_TT_HANDLER; | |
| 491 case TT_OTYPE: return Q_TT_OTYPE; | |
| 492 case TT_ADDRESS_LAST: return Q_TT_ADDRESS_LAST; | |
| 493 default: return Qnil; | |
| 494 } | |
| 495 } | |
| 496 | |
| 497 static Lisp_Object | |
| 498 tt_state_symbol (Tt_state n) | |
| 499 { | |
| 500 switch (n) | |
| 501 { | |
| 502 case TT_CREATED: return Q_TT_CREATED; | |
| 503 case TT_SENT: return Q_TT_SENT; | |
| 504 case TT_HANDLED: return Q_TT_HANDLED; | |
| 505 case TT_FAILED: return Q_TT_FAILED; | |
| 506 case TT_QUEUED: return Q_TT_QUEUED; | |
| 507 case TT_STARTED: return Q_TT_STARTED; | |
| 508 case TT_REJECTED: return Q_TT_REJECTED; | |
| 509 case TT_STATE_LAST: return Q_TT_STATE_LAST; | |
| 510 default: return Qnil; | |
| 511 } | |
| 512 } | |
| 513 | |
| 514 static Lisp_Object | |
| 771 | 515 tt_build_c_string (char *s) |
| 428 | 516 { |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
517 return build_cistring (s ? s : ""); |
| 428 | 518 } |
| 519 | |
| 520 static Lisp_Object | |
| 521 tt_opnum_string (int n) | |
| 522 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
523 Ascbyte buf[32]; |
| 428 | 524 |
| 525 sprintf (buf, "%u", n); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
526 return build_ascstring (buf); |
| 428 | 527 } |
| 528 | |
| 529 static Lisp_Object | |
| 530 tt_message_arg_ival_string (Tt_message m, int n) | |
| 531 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
532 Ascbyte buf[DECIMAL_PRINT_SIZE (long)]; |
| 428 | 533 int value; |
| 534 | |
| 535 check_status (tt_message_arg_ival (m, n, &value)); | |
| 536 long_to_string (buf, value); | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
537 return build_ascstring (buf); |
| 428 | 538 } |
| 539 | |
| 540 static Lisp_Object | |
| 541 tt_message_arg_bval_vector (Tt_message m, int n) | |
| 542 { | |
| 543 /* !!#### This function has not been Mule-ized */ | |
| 867 | 544 Ibyte *value; |
| 428 | 545 int len = 0; |
| 546 | |
| 547 check_status (tt_message_arg_bval (m, n, &value, &len)); | |
| 548 | |
| 549 return make_string (value, len); | |
| 550 } | |
| 551 | |
| 552 DEFUN ("get-tooltalk-message-attribute", Fget_tooltalk_message_attribute, | |
| 553 2, 3, 0, /* | |
| 554 Return the indicated Tooltalk message attribute. Attributes are | |
| 555 identified by symbols with the same name (underscores and all) as the | |
| 556 suffix of the Tooltalk tt_message_<attribute> function that extracts the value. | |
| 557 String attribute values are copied, enumerated type values (except disposition) | |
| 3025 | 558 are converted to symbols - e.g. TT_HANDLER is `TT_HANDLER', uid and gid are |
| 428 | 559 represented by fixnums (small integers), opnum is converted to a string, |
| 560 and disposition is converted to a fixnum. We convert opnum (a C int) to a | |
| 561 string, e.g. 123 => "123" because there's no guarantee that opnums will fit | |
| 562 within the range of Lisp integers. | |
| 563 | |
| 3025 | 564 Use the `plist' attribute instead of the C API `user' attribute |
| 428 | 565 for user defined message data. To retrieve the value of a message property |
| 566 specify the indicator for argn. For example to get the value of a property | |
| 3025 | 567 called `rflag', use |
| 428 | 568 (get-tooltalk-message-attribute message 'plist 'rflag) |
| 569 | |
| 3025 | 570 To get the value of a message argument use one of the `arg_val' (strings), |
| 571 `arg_ival' (integers), or `arg_bval' (strings with embedded nulls), attributes. | |
| 428 | 572 For example to get the integer value of the third argument: |
| 573 | |
| 574 (get-tooltalk-message-attribute message 'arg_ival 2) | |
| 575 | |
| 576 As you can see, argument numbers are zero based. The type of each argument | |
| 3025 | 577 can be retrieved with the `arg_type' attribute; however, Tooltalk doesn't |
| 578 define any semantics for the string value of `arg_type'. Conventionally | |
| 428 | 579 "string" is used for strings and "int" for 32 bit integers. Note that |
| 580 Emacs Lisp stores the lengths of strings explicitly (unlike C) so treating the | |
| 3025 | 581 value returned by `arg_bval' like a string is fine. |
| 428 | 582 */ |
| 583 (message_, attribute, argn)) | |
| 584 { | |
| 585 Tt_message m = unbox_tooltalk_message (message_); | |
| 586 int n = 0; | |
| 587 | |
| 588 CHECK_SYMBOL (attribute); | |
| 589 if (EQ (attribute, (Qtt_arg_bval)) || | |
| 590 EQ (attribute, (Qtt_arg_ival)) || | |
| 591 EQ (attribute, (Qtt_arg_mode)) || | |
| 592 EQ (attribute, (Qtt_arg_type)) || | |
| 593 EQ (attribute, (Qtt_arg_val))) | |
| 594 { | |
| 595 CHECK_INT (argn); | |
| 596 n = XINT (argn); | |
| 597 } | |
| 598 | |
| 599 if (!VALID_TOOLTALK_MESSAGEP (m)) | |
| 600 return Qnil; | |
| 601 | |
| 602 else if (EQ (attribute, Qtt_arg_bval)) | |
| 603 return tt_message_arg_bval_vector (m, n); | |
| 604 | |
| 605 else if (EQ (attribute, Qtt_arg_ival)) | |
| 606 return tt_message_arg_ival_string (m, n); | |
| 607 | |
| 608 else if (EQ (attribute, Qtt_arg_mode)) | |
| 609 return tt_mode_symbol (tt_message_arg_mode (m, n)); | |
| 610 | |
| 611 else if (EQ (attribute, Qtt_arg_type)) | |
| 771 | 612 return tt_build_c_string (tt_message_arg_type (m, n)); |
| 428 | 613 |
| 614 else if (EQ (attribute, Qtt_arg_val)) | |
| 615 return tt_message_arg_bval_vector (m, n); | |
| 616 | |
| 617 else if (EQ (attribute, Qtt_args_count)) | |
| 618 return make_int (tt_message_args_count (m)); | |
| 619 | |
| 620 else if (EQ (attribute, Qtt_address)) | |
| 621 return tt_address_symbol (tt_message_address (m)); | |
| 622 | |
| 623 else if (EQ (attribute, Qtt_class)) | |
| 624 return tt_class_symbol (tt_message_class (m)); | |
| 625 | |
| 626 else if (EQ (attribute, Qtt_disposition)) | |
| 627 return make_int (tt_message_disposition (m)); | |
| 628 | |
| 629 else if (EQ (attribute, Qtt_file)) | |
| 771 | 630 return tt_build_c_string (tt_message_file (m)); |
| 428 | 631 |
| 632 else if (EQ (attribute, Qtt_gid)) | |
| 633 return make_int (tt_message_gid (m)); | |
| 634 | |
| 635 else if (EQ (attribute, Qtt_handler)) | |
| 771 | 636 return tt_build_c_string (tt_message_handler (m)); |
| 428 | 637 |
| 638 else if (EQ (attribute, Qtt_handler_ptype)) | |
| 771 | 639 return tt_build_c_string (tt_message_handler_ptype (m)); |
| 428 | 640 |
| 641 else if (EQ (attribute, Qtt_object)) | |
| 771 | 642 return tt_build_c_string (tt_message_object (m)); |
| 428 | 643 |
| 644 else if (EQ (attribute, Qtt_op)) | |
| 771 | 645 return tt_build_c_string (tt_message_op (m)); |
| 428 | 646 |
| 647 else if (EQ (attribute, Qtt_opnum)) | |
| 648 return tt_opnum_string (tt_message_opnum (m)); | |
| 649 | |
| 650 else if (EQ (attribute, Qtt_otype)) | |
| 771 | 651 return tt_build_c_string (tt_message_otype (m)); |
| 428 | 652 |
| 653 else if (EQ (attribute, Qtt_scope)) | |
| 654 return tt_scope_symbol (tt_message_scope (m)); | |
| 655 | |
| 656 else if (EQ (attribute, Qtt_sender)) | |
| 771 | 657 return tt_build_c_string (tt_message_sender (m)); |
| 428 | 658 |
| 659 else if (EQ (attribute, Qtt_sender_ptype)) | |
| 771 | 660 return tt_build_c_string (tt_message_sender_ptype (m)); |
| 428 | 661 |
| 662 else if (EQ (attribute, Qtt_session)) | |
| 771 | 663 return tt_build_c_string (tt_message_session (m)); |
| 428 | 664 |
| 665 else if (EQ (attribute, Qtt_state)) | |
| 666 return tt_state_symbol (tt_message_state (m)); | |
| 667 | |
| 668 else if (EQ (attribute, Qtt_status)) | |
| 669 return make_int (tt_message_status (m)); | |
| 670 | |
| 671 else if (EQ (attribute, Qtt_status_string)) | |
| 771 | 672 return tt_build_c_string (tt_message_status_string (m)); |
| 428 | 673 |
| 674 else if (EQ (attribute, Qtt_uid)) | |
| 675 return make_int (tt_message_uid (m)); | |
| 676 | |
| 677 else if (EQ (attribute, Qtt_callback)) | |
| 678 return XTOOLTALK_MESSAGE (message_)->callback; | |
| 679 | |
| 680 else if (EQ (attribute, Qtt_prop)) | |
| 681 return Fget (XTOOLTALK_MESSAGE (message_)->plist_sym, argn, Qnil); | |
| 682 | |
| 683 else if (EQ (attribute, Qtt_plist)) | |
| 684 return Fcopy_sequence (Fsymbol_plist | |
| 685 (XTOOLTALK_MESSAGE (message_)->plist_sym)); | |
| 686 | |
| 687 else | |
| 563 | 688 invalid_constant ("Invalid value for `get-tooltalk-message-attribute'", |
| 428 | 689 attribute); |
| 690 | |
| 691 return Qnil; | |
| 692 } | |
| 693 | |
| 694 DEFUN ("set-tooltalk-message-attribute", Fset_tooltalk_message_attribute, | |
| 695 3, 4, 0, /* | |
| 696 Initialize one Tooltalk message attribute. | |
| 697 | |
| 698 Attribute names and values are the same as for | |
| 699 `get-tooltalk-message-attribute'. A property list is provided for user | |
| 3025 | 700 data (instead of the `user' message attribute); see |
| 428 | 701 `get-tooltalk-message-attribute'. |
| 702 | |
| 703 The value of callback should be the name of a function of one argument. | |
| 704 It will be applied to the message and matching pattern each time the state of the | |
| 705 message changes. This is usually used to notice when the messages state has | |
| 706 changed to TT_HANDLED (or TT_FAILED), so that reply argument values | |
| 707 can be used. | |
| 708 | |
| 3025 | 709 If one of the argument attributes is specified, `arg_val', `arg_ival', or |
| 710 `arg_bval' then argn must be the number of an already created argument. | |
| 428 | 711 New arguments can be added to a message with add-tooltalk-message-arg. |
| 712 */ | |
| 713 (value, message_, attribute, argn)) | |
| 714 { | |
| 715 Tt_message m = unbox_tooltalk_message (message_); | |
| 716 int n = 0; | |
| 440 | 717 Tt_status (*fun_str) (Tt_message, const char *) = 0; |
| 428 | 718 |
| 719 CHECK_SYMBOL (attribute); | |
| 440 | 720 |
| 428 | 721 if (EQ (attribute, (Qtt_arg_bval)) || |
| 722 EQ (attribute, (Qtt_arg_ival)) || | |
| 723 EQ (attribute, (Qtt_arg_val))) | |
| 724 { | |
| 725 CHECK_INT (argn); | |
| 726 n = XINT (argn); | |
| 727 } | |
| 728 | |
| 729 if (!VALID_TOOLTALK_MESSAGEP (m)) | |
| 730 return Qnil; | |
| 731 | |
| 440 | 732 if (EQ (attribute, Qtt_address)) |
| 428 | 733 { |
| 734 CHECK_TOOLTALK_CONSTANT (value); | |
| 735 tt_message_address_set (m, (Tt_address) tooltalk_constant_value (value)); | |
| 736 } | |
| 737 else if (EQ (attribute, Qtt_class)) | |
| 738 { | |
| 739 CHECK_TOOLTALK_CONSTANT (value); | |
| 740 tt_message_class_set (m, (Tt_class) tooltalk_constant_value (value)); | |
| 741 } | |
| 742 else if (EQ (attribute, Qtt_disposition)) | |
| 743 { | |
| 744 CHECK_TOOLTALK_CONSTANT (value); | |
| 745 tt_message_disposition_set (m, ((Tt_disposition) | |
| 746 tooltalk_constant_value (value))); | |
| 747 } | |
| 748 else if (EQ (attribute, Qtt_scope)) | |
| 749 { | |
| 750 CHECK_TOOLTALK_CONSTANT (value); | |
| 751 tt_message_scope_set (m, (Tt_scope) tooltalk_constant_value (value)); | |
| 752 } | |
| 440 | 753 else if (EQ (attribute, Qtt_file)) |
| 754 fun_str = tt_message_file_set; | |
| 755 else if (EQ (attribute, Qtt_handler_ptype)) | |
| 756 fun_str = tt_message_handler_ptype_set; | |
| 757 else if (EQ (attribute, Qtt_handler)) | |
| 758 fun_str = tt_message_handler_set; | |
| 759 else if (EQ (attribute, Qtt_object)) | |
| 760 fun_str = tt_message_object_set; | |
| 761 else if (EQ (attribute, Qtt_op)) | |
| 762 fun_str = tt_message_op_set; | |
| 763 else if (EQ (attribute, Qtt_otype)) | |
| 764 fun_str = tt_message_otype_set; | |
| 428 | 765 else if (EQ (attribute, Qtt_sender_ptype)) |
| 440 | 766 fun_str = tt_message_sender_ptype_set; |
| 428 | 767 else if (EQ (attribute, Qtt_session)) |
| 440 | 768 fun_str = tt_message_session_set; |
| 769 else if (EQ (attribute, Qtt_status_string)) | |
| 770 fun_str = tt_message_status_string_set; | |
| 428 | 771 else if (EQ (attribute, Qtt_arg_bval)) |
| 772 { | |
| 773 Extbyte *value_ext; | |
| 665 | 774 Bytecount value_ext_len; |
| 428 | 775 CHECK_STRING (value); |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
776 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
|
777 Qtooltalk_encoding); |
| 444 | 778 tt_message_arg_bval_set (m, n, (unsigned char *) value_ext, value_ext_len); |
| 428 | 779 } |
| 780 else if (EQ (attribute, Qtt_arg_ival)) | |
| 781 { | |
| 782 CHECK_INT (value); | |
| 783 tt_message_arg_ival_set (m, n, XINT (value)); | |
| 784 } | |
| 785 else if (EQ (attribute, Qtt_arg_val)) | |
| 786 { | |
| 442 | 787 const char *value_ext; |
| 428 | 788 CHECK_STRING (value); |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
789 value_ext = LISP_STRING_TO_EXTERNAL (value, Qtooltalk_encoding); |
| 428 | 790 tt_message_arg_val_set (m, n, value_ext); |
| 791 } | |
| 792 else if (EQ (attribute, Qtt_status)) | |
| 793 { | |
| 794 CHECK_INT (value); | |
| 795 tt_message_status_set (m, XINT (value)); | |
| 796 } | |
| 797 else if (EQ (attribute, Qtt_callback)) | |
| 798 { | |
| 799 CHECK_SYMBOL (value); | |
| 800 XTOOLTALK_MESSAGE (message_)->callback = value; | |
| 801 } | |
| 802 else if (EQ (attribute, Qtt_prop)) | |
| 803 { | |
| 804 return Fput (XTOOLTALK_MESSAGE (message_)->plist_sym, argn, value); | |
| 805 } | |
| 806 else | |
| 563 | 807 invalid_constant ("Invalid value for `set-tooltalk-message-attribute'", |
| 428 | 808 attribute); |
| 440 | 809 |
| 810 if (fun_str) | |
| 811 { | |
| 442 | 812 const char *value_ext; |
| 440 | 813 CHECK_STRING (value); |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
814 value_ext = LISP_STRING_TO_EXTERNAL (value, Qtooltalk_encoding); |
| 440 | 815 (*fun_str) (m, value_ext); |
| 816 } | |
| 817 | |
| 428 | 818 return Qnil; |
| 819 } | |
| 820 | |
| 821 DEFUN ("return-tooltalk-message", Freturn_tooltalk_message, 1, 2, 0, /* | |
| 822 Send a reply to this message. The second argument can be | |
| 3025 | 823 `reply', `reject' or `fail'; the default is `reply'. Before sending |
| 428 | 824 a reply all message arguments whose mode is TT_INOUT or TT_OUT should |
| 825 have been filled in - see set-tooltalk-message-attribute. | |
| 826 */ | |
| 827 (message_, mode)) | |
| 828 { | |
| 829 Tt_message m = unbox_tooltalk_message (message_); | |
| 830 | |
| 831 if (NILP (mode)) | |
| 832 mode = Qtt_reply; | |
| 833 else | |
| 834 CHECK_SYMBOL (mode); | |
| 835 | |
| 836 if (!VALID_TOOLTALK_MESSAGEP (m)) | |
| 837 return Qnil; | |
| 838 else if (EQ (mode, Qtt_reply)) | |
| 839 tt_message_reply (m); | |
| 840 else if (EQ (mode, Qtt_reject)) | |
| 841 tt_message_reject (m); | |
| 842 else if (EQ (mode, Qtt_fail)) | |
| 843 tt_message_fail (m); | |
| 844 | |
| 845 return Qnil; | |
| 846 } | |
| 847 | |
| 848 DEFUN ("create-tooltalk-message", Fcreate_tooltalk_message, 0, 1, 0, /* | |
| 849 Create a new tooltalk message. | |
| 850 The messages session attribute is initialized to the default session. | |
| 851 Other attributes can be initialized with `set-tooltalk-message-attribute'. | |
| 852 `make-tooltalk-message' is the preferred to create and initialize a message. | |
| 853 | |
| 854 Optional arg NO-CALLBACK says don't add a C-level callback at all. | |
| 855 Normally don't do that; just don't specify the Lisp callback when | |
| 856 calling `make-tooltalk-message'. | |
| 857 */ | |
| 858 (no_callback)) | |
| 859 { | |
| 860 Tt_message m = tt_message_create (); | |
| 861 Lisp_Object message_ = make_tooltalk_message (m); | |
| 862 if (NILP (no_callback)) | |
| 863 { | |
| 864 tt_message_callback_add (m, tooltalk_message_callback); | |
| 865 } | |
| 866 tt_message_session_set (m, tt_default_session ()); | |
| 867 tt_message_user_set (m, TOOLTALK_MESSAGE_KEY, LISP_TO_VOID (message_)); | |
| 868 return message_; | |
| 869 } | |
| 870 | |
| 871 DEFUN ("destroy-tooltalk-message", Fdestroy_tooltalk_message, 1, 1, 0, /* | |
| 872 Apply tt_message_destroy() to the message. | |
| 873 It's not necessary to destroy messages after they've been processed by | |
| 874 a message or pattern callback; the Lisp/Tooltalk callback machinery does | |
| 875 this for you. | |
| 876 */ | |
| 877 (message_)) | |
| 878 { | |
| 879 Tt_message m = unbox_tooltalk_message (message_); | |
| 880 | |
| 881 if (VALID_TOOLTALK_MESSAGEP (m)) | |
| 882 /* #### Should we call Fremhash() here? It seems that | |
| 883 a common paradigm is | |
| 884 | |
| 885 (send-tooltalk-message) | |
| 886 (destroy-tooltalk-message) | |
| 887 | |
| 888 which would imply that destroying a sent ToolTalk message | |
| 889 doesn't actually destroy it; when a response is sent back, | |
| 890 the callback for the message will still be called. | |
| 891 | |
| 892 But then maybe not: Maybe it really does destroy it, | |
| 893 and the reason for that paradigm is that the author | |
| 894 of `send-tooltalk-message' didn't really know what he | |
| 895 was talking about when he said that it's a good idea | |
| 896 to call `destroy-tooltalk-message' after sending it. */ | |
| 897 tt_message_destroy (m); | |
| 898 | |
| 899 return Qnil; | |
| 900 } | |
| 901 | |
| 902 | |
| 903 DEFUN ("add-tooltalk-message-arg", Fadd_tooltalk_message_arg, 3, 4, 0, /* | |
| 904 Append one new argument to the message. | |
| 905 MODE must be one of TT_IN, TT_INOUT, or TT_OUT; VTYPE must be a string; | |
| 906 and VALUE can be a string or an integer. Tooltalk doesn't | |
| 907 define any semantics for VTYPE, so only the participants in the | |
| 908 protocol you're using need to agree what types mean (if anything). | |
| 909 Conventionally "string" is used for strings and "int" for 32 bit integers. | |
| 910 Arguments can initialized by providing a value or with | |
| 911 `set-tooltalk-message-attribute'. The latter is necessary if you | |
| 912 want to initialize the argument with a string that can contain | |
| 3025 | 913 embedded nulls (use `arg_bval'). |
| 428 | 914 */ |
| 915 (message_, mode, vtype, value)) | |
| 916 { | |
| 917 Tt_message m = unbox_tooltalk_message (message_); | |
| 918 Tt_mode n; | |
| 919 | |
| 920 CHECK_STRING (vtype); | |
| 921 CHECK_TOOLTALK_CONSTANT (mode); | |
| 922 | |
| 923 n = (Tt_mode) tooltalk_constant_value (mode); | |
| 924 | |
| 925 if (!VALID_TOOLTALK_MESSAGEP (m)) | |
| 926 return Qnil; | |
| 927 { | |
| 442 | 928 const char *vtype_ext; |
| 428 | 929 |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
930 vtype_ext = LISP_STRING_TO_EXTERNAL (vtype, Qtooltalk_encoding); |
| 428 | 931 if (NILP (value)) |
| 932 tt_message_arg_add (m, n, vtype_ext, NULL); | |
| 933 else if (STRINGP (value)) | |
| 934 { | |
| 442 | 935 const char *value_ext; |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
936 value_ext = LISP_STRING_TO_EXTERNAL (value, Qtooltalk_encoding); |
| 428 | 937 tt_message_arg_add (m, n, vtype_ext, value_ext); |
| 938 } | |
| 939 else if (INTP (value)) | |
| 940 tt_message_iarg_add (m, n, vtype_ext, XINT (value)); | |
| 941 } | |
| 942 | |
| 943 return Qnil; | |
| 944 } | |
| 945 | |
| 946 DEFUN ("send-tooltalk-message", Fsend_tooltalk_message, 1, 1, 0, /* | |
| 947 Send the message on its way. | |
| 948 Once the message has been sent it's almost always a good idea to get rid of | |
| 949 it with `destroy-tooltalk-message'. | |
| 950 */ | |
| 951 (message_)) | |
| 952 { | |
| 953 Tt_message m = unbox_tooltalk_message (message_); | |
| 954 | |
| 955 if (VALID_TOOLTALK_MESSAGEP (m)) | |
| 956 { | |
| 957 tt_message_send (m); | |
| 958 Fputhash (message_, Qnil, Vtooltalk_message_gcpro); | |
| 959 } | |
| 960 | |
| 961 return Qnil; | |
| 962 } | |
| 963 | |
| 964 DEFUN ("create-tooltalk-pattern", Fcreate_tooltalk_pattern, 0, 0, 0, /* | |
| 965 Create a new Tooltalk pattern. | |
| 966 Its session attribute is initialized to be the default session. | |
| 967 */ | |
| 968 ()) | |
| 969 { | |
| 970 Tt_pattern p = tt_pattern_create (); | |
| 971 Lisp_Object pattern = make_tooltalk_pattern (p); | |
| 972 | |
| 973 tt_pattern_callback_add (p, tooltalk_pattern_callback); | |
| 974 tt_pattern_session_add (p, tt_default_session ()); | |
| 975 tt_pattern_user_set (p, TOOLTALK_PATTERN_KEY, LISP_TO_VOID (pattern)); | |
| 976 | |
| 977 return pattern; | |
| 978 } | |
| 979 | |
| 980 | |
| 981 DEFUN ("destroy-tooltalk-pattern", Fdestroy_tooltalk_pattern, 1, 1, 0, /* | |
| 982 Apply tt_pattern_destroy() to the pattern. | |
| 983 This effectively unregisters the pattern. | |
| 984 */ | |
| 985 (pattern)) | |
| 986 { | |
| 987 Tt_pattern p = unbox_tooltalk_pattern (pattern); | |
| 988 | |
| 989 if (VALID_TOOLTALK_PATTERNP (p)) | |
| 990 { | |
| 991 tt_pattern_destroy (p); | |
| 992 Fremhash (pattern, Vtooltalk_pattern_gcpro); | |
| 993 } | |
| 994 | |
| 995 return Qnil; | |
| 996 } | |
| 997 | |
| 998 | |
| 999 DEFUN ("add-tooltalk-pattern-attribute", Fadd_tooltalk_pattern_attribute, 3, 3, 0, /* | |
| 1000 Add one value to the indicated pattern attribute. | |
| 3025 | 1001 All Tooltalk pattern attributes are supported except `user'. The names |
| 428 | 1002 of attributes are the same as the Tooltalk accessors used to set them |
| 1003 less the "tooltalk_pattern_" prefix and the "_add" ... | |
| 1004 */ | |
| 1005 (value, pattern, attribute)) | |
| 1006 { | |
| 1007 Tt_pattern p = unbox_tooltalk_pattern (pattern); | |
| 1008 | |
| 1009 CHECK_SYMBOL (attribute); | |
| 1010 | |
| 1011 if (!VALID_TOOLTALK_PATTERNP (p)) | |
| 1012 return Qnil; | |
| 1013 | |
| 1014 else if (EQ (attribute, Qtt_category)) | |
| 1015 { | |
| 1016 CHECK_TOOLTALK_CONSTANT (value); | |
| 1017 tt_pattern_category_set (p, ((Tt_category) | |
| 1018 tooltalk_constant_value (value))); | |
| 1019 } | |
| 1020 else if (EQ (attribute, Qtt_address)) | |
| 1021 { | |
| 1022 CHECK_TOOLTALK_CONSTANT (value); | |
| 1023 tt_pattern_address_add (p, ((Tt_address) | |
| 1024 tooltalk_constant_value (value))); | |
| 1025 } | |
| 1026 else if (EQ (attribute, Qtt_class)) | |
| 1027 { | |
| 1028 CHECK_TOOLTALK_CONSTANT (value); | |
| 1029 tt_pattern_class_add (p, (Tt_class) tooltalk_constant_value (value)); | |
| 1030 } | |
| 1031 else if (EQ (attribute, Qtt_disposition)) | |
| 1032 { | |
| 1033 CHECK_TOOLTALK_CONSTANT (value); | |
| 1034 tt_pattern_disposition_add (p, ((Tt_disposition) | |
| 1035 tooltalk_constant_value (value))); | |
| 1036 } | |
| 1037 else if (EQ (attribute, Qtt_file)) | |
| 1038 { | |
| 442 | 1039 const char *value_ext; |
| 428 | 1040 CHECK_STRING (value); |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
1041 value_ext = LISP_STRING_TO_EXTERNAL (value, Qtooltalk_encoding); |
| 428 | 1042 tt_pattern_file_add (p, value_ext); |
| 1043 } | |
| 1044 else if (EQ (attribute, Qtt_object)) | |
| 1045 { | |
| 442 | 1046 const char *value_ext; |
| 428 | 1047 CHECK_STRING (value); |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
1048 value_ext = LISP_STRING_TO_EXTERNAL (value, Qtooltalk_encoding); |
| 428 | 1049 tt_pattern_object_add (p, value_ext); |
| 1050 } | |
| 1051 else if (EQ (attribute, Qtt_op)) | |
| 1052 { | |
| 442 | 1053 const char *value_ext; |
| 428 | 1054 CHECK_STRING (value); |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
1055 value_ext = LISP_STRING_TO_EXTERNAL (value, Qtooltalk_encoding); |
| 428 | 1056 tt_pattern_op_add (p, value_ext); |
| 1057 } | |
| 1058 else if (EQ (attribute, Qtt_otype)) | |
| 1059 { | |
| 442 | 1060 const char *value_ext; |
| 428 | 1061 CHECK_STRING (value); |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
1062 value_ext = LISP_STRING_TO_EXTERNAL (value, Qtooltalk_encoding); |
| 428 | 1063 tt_pattern_otype_add (p, value_ext); |
| 1064 } | |
| 1065 else if (EQ (attribute, Qtt_scope)) | |
| 1066 { | |
| 1067 CHECK_TOOLTALK_CONSTANT (value); | |
| 1068 tt_pattern_scope_add (p, (Tt_scope) tooltalk_constant_value (value)); | |
| 1069 } | |
| 1070 else if (EQ (attribute, Qtt_sender)) | |
| 1071 { | |
| 442 | 1072 const char *value_ext; |
| 428 | 1073 CHECK_STRING (value); |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
1074 value_ext = LISP_STRING_TO_EXTERNAL (value, Qtooltalk_encoding); |
| 428 | 1075 tt_pattern_sender_add (p, value_ext); |
| 1076 } | |
| 1077 else if (EQ (attribute, Qtt_sender_ptype)) | |
| 1078 { | |
| 442 | 1079 const char *value_ext; |
| 428 | 1080 CHECK_STRING (value); |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
1081 value_ext = LISP_STRING_TO_EXTERNAL (value, Qtooltalk_encoding); |
| 428 | 1082 tt_pattern_sender_ptype_add (p, value_ext); |
| 1083 } | |
| 1084 else if (EQ (attribute, Qtt_session)) | |
| 1085 { | |
| 442 | 1086 const char *value_ext; |
| 428 | 1087 CHECK_STRING (value); |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
1088 value_ext = LISP_STRING_TO_EXTERNAL (value, Qtooltalk_encoding); |
| 428 | 1089 tt_pattern_session_add (p, value_ext); |
| 1090 } | |
| 1091 else if (EQ (attribute, Qtt_state)) | |
| 1092 { | |
| 1093 CHECK_TOOLTALK_CONSTANT (value); | |
| 1094 tt_pattern_state_add (p, (Tt_state) tooltalk_constant_value (value)); | |
| 1095 } | |
| 1096 else if (EQ (attribute, Qtt_callback)) | |
| 1097 { | |
| 1098 CHECK_SYMBOL (value); | |
| 1099 XTOOLTALK_PATTERN (pattern)->callback = value; | |
| 1100 } | |
| 1101 | |
| 1102 return Qnil; | |
| 1103 } | |
| 1104 | |
| 1105 | |
| 1106 DEFUN ("add-tooltalk-pattern-arg", Fadd_tooltalk_pattern_arg, 3, 4, 0, /* | |
| 1107 Add one fully specified argument to a tooltalk pattern. | |
| 1108 Mode must be one of TT_IN, TT_INOUT, or TT_OUT, type must be a string. | |
| 1109 Value can be an integer, string or nil. If value is an integer then | |
| 1110 an integer argument (tt_pattern_iarg_add) added otherwise a string argument | |
| 1111 is added. At present there's no way to add a binary data argument. | |
| 1112 */ | |
| 1113 (pattern, mode, vtype, value)) | |
| 1114 { | |
| 1115 Tt_pattern p = unbox_tooltalk_pattern (pattern); | |
| 1116 Tt_mode n; | |
| 1117 | |
| 1118 CHECK_STRING (vtype); | |
| 1119 CHECK_TOOLTALK_CONSTANT (mode); | |
| 1120 | |
| 1121 n = (Tt_mode) tooltalk_constant_value (mode); | |
| 1122 | |
| 1123 if (!VALID_TOOLTALK_PATTERNP (p)) | |
| 1124 return Qnil; | |
| 1125 | |
| 1126 { | |
| 442 | 1127 const char *vtype_ext; |
| 428 | 1128 |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
1129 vtype_ext = LISP_STRING_TO_EXTERNAL (vtype, Qtooltalk_encoding); |
| 428 | 1130 if (NILP (value)) |
| 1131 tt_pattern_arg_add (p, n, vtype_ext, NULL); | |
| 1132 else if (STRINGP (value)) | |
| 1133 { | |
| 442 | 1134 const char *value_ext; |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
1135 value_ext = LISP_STRING_TO_EXTERNAL (value, Qtooltalk_encoding); |
| 428 | 1136 tt_pattern_arg_add (p, n, vtype_ext, value_ext); |
| 1137 } | |
| 1138 else if (INTP (value)) | |
| 1139 tt_pattern_iarg_add (p, n, vtype_ext, XINT (value)); | |
| 1140 } | |
| 1141 | |
| 1142 return Qnil; | |
| 1143 } | |
| 1144 | |
| 1145 | |
| 1146 DEFUN ("register-tooltalk-pattern", Fregister_tooltalk_pattern, 1, 1, 0, /* | |
| 1147 Emacs will begin receiving messages that match this pattern. | |
| 1148 */ | |
| 1149 (pattern)) | |
| 1150 { | |
| 1151 Tt_pattern p = unbox_tooltalk_pattern (pattern); | |
| 1152 | |
| 1153 if (VALID_TOOLTALK_PATTERNP (p) && tt_pattern_register (p) == TT_OK) | |
| 1154 { | |
| 1155 Fputhash (pattern, Qnil, Vtooltalk_pattern_gcpro); | |
| 1156 return Qt; | |
| 1157 } | |
| 1158 else | |
| 1159 return Qnil; | |
| 1160 } | |
| 1161 | |
| 1162 | |
| 1163 DEFUN ("unregister-tooltalk-pattern", Funregister_tooltalk_pattern, 1, 1, 0, /* | |
| 1164 Emacs will stop receiving messages that match this pattern. | |
| 1165 */ | |
| 1166 (pattern)) | |
| 1167 { | |
| 1168 Tt_pattern p = unbox_tooltalk_pattern (pattern); | |
| 1169 | |
| 1170 if (VALID_TOOLTALK_PATTERNP (p)) | |
| 1171 { | |
| 1172 tt_pattern_unregister (p); | |
| 1173 Fremhash (pattern, Vtooltalk_pattern_gcpro); | |
| 1174 } | |
| 1175 | |
| 1176 return Qnil; | |
| 1177 } | |
| 1178 | |
| 1179 | |
| 1180 DEFUN ("tooltalk-pattern-prop-get", Ftooltalk_pattern_prop_get, 2, 2, 0, /* | |
| 1181 Return the value of PROPERTY in tooltalk pattern PATTERN. | |
| 1182 This is the last value set with `tooltalk-pattern-prop-set'. | |
| 1183 */ | |
| 1184 (pattern, property)) | |
| 1185 { | |
| 1186 CHECK_TOOLTALK_PATTERN (pattern); | |
| 1187 return Fget (XTOOLTALK_PATTERN (pattern)->plist_sym, property, Qnil); | |
| 1188 } | |
| 1189 | |
| 1190 | |
| 1191 DEFUN ("tooltalk-pattern-prop-set", Ftooltalk_pattern_prop_set, 3, 3, 0, /* | |
| 1192 Set the value of PROPERTY to VALUE in tooltalk pattern PATTERN. | |
| 1193 It can be retrieved with `tooltalk-pattern-prop-get'. | |
| 1194 */ | |
| 1195 (pattern, property, value)) | |
| 1196 { | |
| 1197 CHECK_TOOLTALK_PATTERN (pattern); | |
| 1198 return Fput (XTOOLTALK_PATTERN (pattern)->plist_sym, property, value); | |
| 1199 } | |
| 1200 | |
| 1201 | |
| 1202 DEFUN ("tooltalk-pattern-plist-get", Ftooltalk_pattern_plist_get, 1, 1, 0, /* | |
| 1203 Return the a list of all the properties currently set in PATTERN. | |
| 1204 */ | |
| 1205 (pattern)) | |
| 1206 { | |
| 1207 CHECK_TOOLTALK_PATTERN (pattern); | |
| 1208 return | |
| 1209 Fcopy_sequence (Fsymbol_plist (XTOOLTALK_PATTERN (pattern)->plist_sym)); | |
| 1210 } | |
| 1211 | |
| 1212 DEFUN ("tooltalk-default-procid", Ftooltalk_default_procid, 0, 0, 0, /* | |
| 1213 Return current default process identifier for your process. | |
| 1214 */ | |
| 1215 ()) | |
| 1216 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1217 Extbyte *procid = tt_default_procid (); |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
1218 return procid ? build_extstring (procid, Qtooltalk_encoding) : Qnil; |
| 428 | 1219 } |
| 1220 | |
| 1221 DEFUN ("tooltalk-default-session", Ftooltalk_default_session, 0, 0, 0, /* | |
| 1222 Return current default session identifier for the current default procid. | |
| 1223 */ | |
| 1224 ()) | |
| 1225 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1226 Extbyte *session = tt_default_session (); |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
1227 return session ? build_extstring (session, Qtooltalk_encoding) : Qnil; |
| 428 | 1228 } |
| 1229 | |
| 1230 static void | |
| 1231 init_tooltalk (void) | |
| 1232 { | |
| 1233 /* This function can GC */ | |
| 1234 char *retval; | |
| 1235 Lisp_Object lp; | |
| 1236 Lisp_Object fil; | |
| 1237 | |
| 1238 | |
| 440 | 1239 /* tt_open() messes with our signal handler flags (at least when no |
| 1240 ttsessions is running on the machine), therefore we save the | |
| 428 | 1241 actions and restore them after the call */ |
| 1242 #ifdef HAVE_SIGPROCMASK | |
| 1243 { | |
| 1244 struct sigaction ActSIGQUIT; | |
| 1245 struct sigaction ActSIGINT; | |
| 1246 struct sigaction ActSIGCHLD; | |
| 1247 sigaction (SIGQUIT, NULL, &ActSIGQUIT); | |
| 1248 sigaction (SIGINT, NULL, &ActSIGINT); | |
| 1249 sigaction (SIGCHLD, NULL, &ActSIGCHLD); | |
| 1250 #endif | |
| 1251 retval = tt_open (); | |
| 1252 #ifdef HAVE_SIGPROCMASK | |
| 1253 sigaction (SIGQUIT, &ActSIGQUIT, NULL); | |
| 1254 sigaction (SIGINT, &ActSIGINT, NULL); | |
| 1255 sigaction (SIGCHLD, &ActSIGCHLD, NULL); | |
| 1256 } | |
| 1257 #endif | |
| 1258 | |
| 1259 | |
| 1260 if (tt_ptr_error (retval) != TT_OK) | |
| 1261 return; | |
| 1262 | |
| 1263 Vtooltalk_fd = make_int (tt_fd ()); | |
| 1264 | |
| 1265 tt_session_join (tt_default_session ()); | |
| 1266 | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1267 lp = connect_to_file_descriptor (build_ascstring ("tooltalk"), Qnil, |
| 428 | 1268 Vtooltalk_fd, Vtooltalk_fd); |
| 1269 if (!NILP (lp)) | |
| 1270 { | |
| 1271 /* Don't ask the user for confirmation when exiting Emacs */ | |
| 1272 Fprocess_kill_without_query (lp, Qnil); | |
| 2834 | 1273 fil = GET_DEFUN_LISP_OBJECT (Freceive_tooltalk_message); |
| 853 | 1274 set_process_filter (lp, fil, 1, 0); |
| 428 | 1275 } |
| 1276 else | |
| 1277 { | |
| 1278 tt_close (); | |
| 1279 Vtooltalk_fd = Qnil; | |
| 1280 return; | |
| 1281 } | |
| 1282 | |
| 1283 #if defined (SOLARIS2) | |
| 1284 /* Apparently the tt_message_send_on_exit() function does not exist | |
| 1285 under SunOS 4.x or IRIX 5 or various other non-Solaris-2 systems. | |
| 1286 No big deal if we don't do the following under those systems. */ | |
| 1287 { | |
| 1288 Tt_message exit_msg = tt_message_create (); | |
| 1289 | |
| 1290 tt_message_op_set (exit_msg, "emacs-aborted"); | |
| 1291 tt_message_scope_set (exit_msg, TT_SESSION); | |
| 1292 tt_message_class_set (exit_msg, TT_NOTICE); | |
| 1293 tt_message_send_on_exit (exit_msg); | |
| 1294 tt_message_destroy (exit_msg); | |
| 1295 } | |
| 1296 #endif | |
| 1297 } | |
| 1298 | |
| 1299 DEFUN ("tooltalk-open-connection", Ftooltalk_open_connection, 0, 0, 0, /* | |
| 1300 Opens a connection to the ToolTalk server. | |
| 1301 Returns t if successful, nil otherwise. | |
| 1302 */ | |
| 1303 ()) | |
| 1304 { | |
| 1305 if (!NILP (Vtooltalk_fd)) | |
| 563 | 1306 signal_error (Qio_error, "Already connected to ToolTalk", Qunbound); |
| 428 | 1307 if (noninteractive) |
| 563 | 1308 signal_error (Qio_error, "Can't connect to ToolTalk in batch mode", Qunbound); |
| 428 | 1309 init_tooltalk (); |
| 1310 return NILP (Vtooltalk_fd) ? Qnil : Qt; | |
| 1311 } | |
| 1312 | |
| 1313 | |
| 1314 void | |
| 1315 syms_of_tooltalk (void) | |
| 1316 { | |
| 442 | 1317 INIT_LRECORD_IMPLEMENTATION (tooltalk_message); |
| 1318 INIT_LRECORD_IMPLEMENTATION (tooltalk_pattern); | |
| 1319 | |
| 563 | 1320 DEFSYMBOL_MULTIWORD_PREDICATE (Qtooltalk_messagep); |
| 428 | 1321 DEFSUBR (Ftooltalk_message_p); |
| 563 | 1322 DEFSYMBOL_MULTIWORD_PREDICATE (Qtooltalk_patternp); |
| 428 | 1323 DEFSUBR (Ftooltalk_pattern_p); |
| 563 | 1324 DEFSYMBOL (Qtooltalk_message_handler_hook); |
| 1325 DEFSYMBOL (Qtooltalk_pattern_handler_hook); | |
| 1326 DEFSYMBOL (Qtooltalk_unprocessed_message_hook); | |
| 428 | 1327 |
| 1328 DEFSUBR (Freceive_tooltalk_message); | |
| 1329 DEFSUBR (Fcreate_tooltalk_message); | |
| 1330 DEFSUBR (Fdestroy_tooltalk_message); | |
| 1331 DEFSUBR (Fadd_tooltalk_message_arg); | |
| 1332 DEFSUBR (Fget_tooltalk_message_attribute); | |
| 1333 DEFSUBR (Fset_tooltalk_message_attribute); | |
| 1334 DEFSUBR (Fsend_tooltalk_message); | |
| 1335 DEFSUBR (Freturn_tooltalk_message); | |
| 1336 DEFSUBR (Fcreate_tooltalk_pattern); | |
| 1337 DEFSUBR (Fdestroy_tooltalk_pattern); | |
| 1338 DEFSUBR (Fadd_tooltalk_pattern_attribute); | |
| 1339 DEFSUBR (Fadd_tooltalk_pattern_arg); | |
| 1340 DEFSUBR (Fregister_tooltalk_pattern); | |
| 1341 DEFSUBR (Funregister_tooltalk_pattern); | |
| 1342 DEFSUBR (Ftooltalk_pattern_plist_get); | |
| 1343 DEFSUBR (Ftooltalk_pattern_prop_set); | |
| 1344 DEFSUBR (Ftooltalk_pattern_prop_get); | |
| 1345 DEFSUBR (Ftooltalk_default_procid); | |
| 1346 DEFSUBR (Ftooltalk_default_session); | |
| 1347 DEFSUBR (Ftooltalk_open_connection); | |
| 1348 | |
| 563 | 1349 DEFSYMBOL (Qreceive_tooltalk_message); |
| 428 | 1350 defsymbol (&Qtt_address, "address"); |
| 1351 defsymbol (&Qtt_args_count, "args_count"); | |
| 1352 defsymbol (&Qtt_arg_bval, "arg_bval"); | |
| 1353 defsymbol (&Qtt_arg_ival, "arg_ival"); | |
| 1354 defsymbol (&Qtt_arg_mode, "arg_mode"); | |
| 1355 defsymbol (&Qtt_arg_type, "arg_type"); | |
| 1356 defsymbol (&Qtt_arg_val, "arg_val"); | |
| 1357 defsymbol (&Qtt_class, "class"); | |
| 1358 defsymbol (&Qtt_category, "category"); | |
| 1359 defsymbol (&Qtt_disposition, "disposition"); | |
| 1360 defsymbol (&Qtt_file, "file"); | |
| 1361 defsymbol (&Qtt_gid, "gid"); | |
| 1362 defsymbol (&Qtt_handler, "handler"); | |
| 1363 defsymbol (&Qtt_handler_ptype, "handler_ptype"); | |
| 1364 defsymbol (&Qtt_object, "object"); | |
| 1365 defsymbol (&Qtt_op, "op"); | |
| 1366 defsymbol (&Qtt_opnum, "opnum"); | |
| 1367 defsymbol (&Qtt_otype, "otype"); | |
| 1368 defsymbol (&Qtt_scope, "scope"); | |
| 1369 defsymbol (&Qtt_sender, "sender"); | |
| 1370 defsymbol (&Qtt_sender_ptype, "sender_ptype"); | |
| 1371 defsymbol (&Qtt_session, "session"); | |
| 1372 defsymbol (&Qtt_state, "state"); | |
| 1373 defsymbol (&Qtt_status, "status"); | |
| 1374 defsymbol (&Qtt_status_string, "status_string"); | |
| 1375 defsymbol (&Qtt_uid, "uid"); | |
| 1376 defsymbol (&Qtt_callback, "callback"); | |
| 1377 defsymbol (&Qtt_prop, "prop"); | |
| 1378 defsymbol (&Qtt_plist, "plist"); | |
| 1379 defsymbol (&Qtt_reject, "reject"); | |
| 1380 defsymbol (&Qtt_reply, "reply"); | |
| 1381 defsymbol (&Qtt_fail, "fail"); | |
| 1382 | |
| 442 | 1383 DEFERROR (Qtooltalk_error, "ToolTalk error", Qio_error); |
| 428 | 1384 } |
| 1385 | |
| 1386 void | |
| 1387 vars_of_tooltalk (void) | |
| 1388 { | |
| 1389 Fprovide (intern ("tooltalk")); | |
| 1390 | |
| 1391 DEFVAR_LISP ("tooltalk-fd", &Vtooltalk_fd /* | |
| 1392 File descriptor returned by tt_initialize; nil if not connected to ToolTalk. | |
| 1393 */ ); | |
| 1394 Vtooltalk_fd = Qnil; | |
| 1395 | |
| 1396 DEFVAR_LISP ("tooltalk-message-handler-hook", | |
| 1397 &Vtooltalk_message_handler_hook /* | |
| 1398 List of functions to be applied to each ToolTalk message reply received. | |
| 1399 This will always occur as a result of our sending a request message. | |
| 1400 Functions will be called with two arguments, the message and the | |
| 1401 corresponding pattern. This hook will not be called if the request | |
| 1402 message was created without a C-level callback function (see | |
| 1403 `tooltalk-unprocessed-message-hook'). | |
| 1404 */ ); | |
| 1405 Vtooltalk_message_handler_hook = Qnil; | |
| 1406 | |
| 1407 DEFVAR_LISP ("tooltalk-pattern-handler-hook", | |
| 1408 &Vtooltalk_pattern_handler_hook /* | |
| 1409 List of functions to be applied to each pattern-matching ToolTalk message. | |
| 1410 This is all messages except those handled by `tooltalk-message-handler-hook'. | |
| 1411 Functions will be called with two arguments, the message and the | |
| 1412 corresponding pattern. | |
| 1413 */ ); | |
| 1414 Vtooltalk_pattern_handler_hook = Qnil; | |
| 1415 | |
| 1416 DEFVAR_LISP ("tooltalk-unprocessed-message-hook", | |
| 1417 &Vtooltalk_unprocessed_message_hook /* | |
| 1418 List of functions to be applied to each unprocessed ToolTalk message. | |
| 1419 Unprocessed messages are messages that didn't match any patterns. | |
| 1420 */ ); | |
| 1421 Vtooltalk_unprocessed_message_hook = Qnil; | |
| 1422 | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1423 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
|
1424 Tooltalk_Pattern_plist_str = build_defer_string ("Tooltalk Pattern plist"); |
| 428 | 1425 |
| 1426 staticpro(&Tooltalk_Message_plist_str); | |
| 1427 staticpro(&Tooltalk_Pattern_plist_str); | |
| 1428 | |
| 1429 #define MAKE_CONSTANT(name) do { \ | |
| 1430 defsymbol (&Q_ ## name, #name); \ | |
| 1431 Fset (Q_ ## name, make_int (name)); \ | |
| 1432 } while (0) | |
| 1433 | |
| 1434 MAKE_CONSTANT (TT_MODE_UNDEFINED); | |
| 1435 MAKE_CONSTANT (TT_IN); | |
| 1436 MAKE_CONSTANT (TT_OUT); | |
| 1437 MAKE_CONSTANT (TT_INOUT); | |
| 1438 MAKE_CONSTANT (TT_MODE_LAST); | |
| 1439 | |
| 1440 MAKE_CONSTANT (TT_SCOPE_NONE); | |
| 1441 MAKE_CONSTANT (TT_SESSION); | |
| 1442 MAKE_CONSTANT (TT_FILE); | |
| 1443 MAKE_CONSTANT (TT_BOTH); | |
| 1444 MAKE_CONSTANT (TT_FILE_IN_SESSION); | |
| 1445 | |
| 1446 MAKE_CONSTANT (TT_CLASS_UNDEFINED); | |
| 1447 MAKE_CONSTANT (TT_NOTICE); | |
| 1448 MAKE_CONSTANT (TT_REQUEST); | |
| 1449 MAKE_CONSTANT (TT_CLASS_LAST); | |
| 1450 | |
| 1451 MAKE_CONSTANT (TT_CATEGORY_UNDEFINED); | |
| 1452 MAKE_CONSTANT (TT_OBSERVE); | |
| 1453 MAKE_CONSTANT (TT_HANDLE); | |
| 1454 MAKE_CONSTANT (TT_CATEGORY_LAST); | |
| 1455 | |
| 1456 MAKE_CONSTANT (TT_PROCEDURE); | |
| 1457 MAKE_CONSTANT (TT_OBJECT); | |
| 1458 MAKE_CONSTANT (TT_HANDLER); | |
| 1459 MAKE_CONSTANT (TT_OTYPE); | |
| 1460 MAKE_CONSTANT (TT_ADDRESS_LAST); | |
| 1461 | |
| 1462 MAKE_CONSTANT (TT_CREATED); | |
| 1463 MAKE_CONSTANT (TT_SENT); | |
| 1464 MAKE_CONSTANT (TT_HANDLED); | |
| 1465 MAKE_CONSTANT (TT_FAILED); | |
| 1466 MAKE_CONSTANT (TT_QUEUED); | |
| 1467 MAKE_CONSTANT (TT_STARTED); | |
| 1468 MAKE_CONSTANT (TT_REJECTED); | |
| 1469 MAKE_CONSTANT (TT_STATE_LAST); | |
| 1470 | |
| 1471 MAKE_CONSTANT (TT_DISCARD); | |
| 1472 MAKE_CONSTANT (TT_QUEUE); | |
| 1473 MAKE_CONSTANT (TT_START); | |
| 1474 | |
| 1475 #undef MAKE_CONSTANT | |
| 1476 | |
| 1477 staticpro (&Vtooltalk_message_gcpro); | |
| 1478 staticpro (&Vtooltalk_pattern_gcpro); | |
| 1479 Vtooltalk_message_gcpro = | |
| 1480 make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); | |
| 1481 Vtooltalk_pattern_gcpro = | |
| 1482 make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); | |
| 1483 } |