cgit.sxemacs.org Git - sxemacs/blob - src/ui/X11/dialog-x.c

   1 /* Implements elisp-programmable dialog boxes -- X interface.
   2    Copyright (C) 1993, 1994 Free Software Foundation, Inc.
   3    Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
   4    Copyright (C) 2000 Ben Wing.
   5
   6 This file is part of SXEmacs
   7
   8 SXEmacs is free software: you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation, either version 3 of the License, or
  11 (at your option) any later version.
  12
  13 SXEmacs is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with this program.  If not, see <http://www.gnu.org/licenses/>. */
  20
  21
  22 /* Synched up with: Not in FSF. */
  23
  24 /* This file Mule-ized by Ben Wing, 7-8-00. */
  25
  26 #include <config.h>
  27 #include "lisp.h"
  28
  29 #include "console-x.h"
  30 #include "EmacsFrame.h"
  31 #include "gui-x.h"
  32
  33 #include "buffer.h"
  34 #include "commands.h"           /* zmacs_regions */
  35 #include "events/events.h"
  36 #include "ui/frame.h"
  37 #include "ui/gui.h"
  38 #include "opaque.h"
  39 #include "ui/window.h"
  40
  41 static void maybe_run_dbox_text_callback(LWLIB_ID id)
  42 {
  43         widget_value *wv;
  44         int got_some;
  45         wv = xmalloc_widget_value();
  46         wv->name = xstrdup("value");
  47         got_some = lw_get_some_values(id, wv);
  48         if (got_some) {
  49                 Lisp_Object text_field_callback;
  50                 Extbyte *text_field_value = wv->value;
  51                 VOID_TO_LISP(text_field_callback, wv->call_data);
  52                 text_field_callback = XCAR(XCDR(text_field_callback));
  53                 if (text_field_value) {
  54                         Lisp_Object tmp1 =
  55                                 cons3(Qnil,
  56                                       list2(text_field_callback,
  57                                             build_ext_string(text_field_value,
  58                                                              Qlwlib_encoding)),
  59                                       Qnil);
  60                         void *tmp2 = LISP_TO_VOID(tmp1);
  61                         popup_selection_callback(0, id, (XtPointer)tmp2);
  62                 }
  63         }
  64         /* This code tried to optimize, newing/freeing. This is generally
  65            unsafe so we will always strdup and always use
  66            free_widget_value_tree. */
  67         free_widget_value_tree(wv);
  68 }
  69
  70 static void
  71 dbox_selection_callback(Widget widget, LWLIB_ID id, XtPointer client_data)
  72 {
  73         /* This is called with client_data == -1 when WM_DELETE_WINDOW is sent
  74            instead of a button being selected. */
  75         struct device *d = get_device_from_display(XtDisplay(widget));
  76         struct frame *f = 0;
  77         Widget cur_widget = widget;
  78
  79         /* The parent which is actually connected to our EmacsFrame may be a
  80            ways up the tree. */
  81         while (!f && cur_widget) {
  82                 f = x_any_window_to_frame(d, XtWindow(cur_widget));
  83                 cur_widget = XtParent(cur_widget);
  84         }
  85
  86         if (popup_handled_p(id))
  87                 return;
  88         assert(popup_up_p != 0);
  89         ungcpro_popup_callbacks(id);
  90         popup_up_p--;
  91         maybe_run_dbox_text_callback(id);
  92         popup_selection_callback(widget, id, client_data);
  93         /* #### need to error-protect!  will do so when i merge in
  94            my working ws */
  95         va_run_hook_with_args(Qdelete_dialog_box_hook, 1, make_int(id));
  96         lw_destroy_all_widgets(id);
  97
  98         /* The Motif dialog box sets the keyboard focus to itself.  When it
  99            goes away we have to take care of getting the focus back
 100            ourselves. */
 101 #ifdef EXTERNAL_WIDGET
 102         /* #### Not sure if this special case is necessary. */
 103         if (f && !FRAME_X_EXTERNAL_WINDOW_P(f) )
 104 #else
 105         if (f)
 106 #endif
 107                 lw_set_keyboard_focus(FRAME_X_SHELL_WIDGET(f),
 108                                       FRAME_X_TEXT_WIDGET(f));
 109 }
 110
 111 static const Extbyte *const button_names[] = {
 112         "button1", "button2", "button3", "button4", "button5",
 113         "button6", "button7", "button8", "button9", "button10"
 114 };
 115
 116 static widget_value *dbox_descriptor_to_widget_value(Lisp_Object keys)
 117 {
 118         /* This function can GC */
 119         int lbuttons = 0, rbuttons = 0;
 120         int partition_seen = 0;
 121         int text_field_p = 0;
 122         int allow_text_p = 1;
 123         widget_value *prev = 0, *kids = 0;
 124         int n = 0;
 125         int count = specpdl_depth();
 126         Lisp_Object wv_closure, gui_item;
 127         Lisp_Object question = Qnil;
 128         Lisp_Object title = Qnil;       /* #### currently unused */
 129         Lisp_Object buttons = Qnil;
 130
 131         {
 132                 EXTERNAL_PROPERTY_LIST_LOOP_3(key, value, keys) {
 133                         if (EQ(key, Q_question)) {
 134                                 CHECK_STRING(value);
 135                                 question = value;
 136                         } else if (EQ(key, Q_title)) {
 137                                 CHECK_STRING(value);
 138                                 title = value;
 139                         } else if (EQ(key, Q_buttons)) {
 140                                 CHECK_LIST(value);
 141                                 buttons = value;
 142                         } else
 143                                 syntax_error
 144                                     ("Unrecognized question-dialog keyword",
 145                                      key);
 146                 }
 147         }
 148
 149         if (NILP(question))
 150                 syntax_error("Dialog descriptor provides no question", keys);
 151
 152         /* Inhibit GC during this conversion.  The reasons for this are
 153            the same as in menu_item_descriptor_to_widget_value(); see
 154            the large comment above that function. */
 155
 156         record_unwind_protect(restore_gc_inhibit,
 157                               make_int(gc_currently_forbidden));
 158         gc_currently_forbidden = 1;
 159
 160         kids = prev = xmalloc_widget_value();
 161
 162         /* Also make sure that we free the partially-created widget_value
 163            tree on Lisp error. */
 164
 165         wv_closure = make_opaque_ptr(kids);
 166         record_unwind_protect(widget_value_unwind, wv_closure);
 167         prev->name = xstrdup("message");
 168         LISP_STRING_TO_EXTERNAL_MALLOC(question, prev->value, Qlwlib_encoding);
 169         prev->enabled = 1;
 170
 171         {
 172                 EXTERNAL_LIST_LOOP_2(button, buttons) {
 173                         widget_value *wv;
 174
 175                         if (NILP(button)) {
 176                                 if (partition_seen)
 177                                         syntax_error
 178                                             ("More than one partition (nil) seen in dbox spec",
 179                                              keys);
 180                                 partition_seen = 1;
 181                                 continue;
 182                         }
 183                         CHECK_VECTOR(button);
 184                         wv = xmalloc_widget_value();
 185
 186                         gui_item = gui_parse_item_keywords(button);
 187                         if (!button_item_to_widget_value(Qdialog,
 188                                                          gui_item, wv,
 189                                                          allow_text_p, 1, 0,
 190                                                          1)) {
 191                                 free_widget_value_tree(wv);
 192                                 continue;
 193                         }
 194
 195                         if (wv->type == TEXT_TYPE) {
 196                                 text_field_p = 1;
 197                                 allow_text_p = 0;       /* only allow one */
 198                         } else {        /* it's a button */
 199
 200                                 allow_text_p = 0;       /* only allow text field at the front */
 201                                 if (wv->value)
 202                                         xfree(wv->value);
 203                                 wv->value = wv->name;   /* what a mess... */
 204                                 wv->name = xstrdup(button_names[n]);
 205
 206                                 if (partition_seen)
 207                                         rbuttons++;
 208                                 else
 209                                         lbuttons++;
 210                                 n++;
 211
 212                                 if (lbuttons > 9 || rbuttons > 9)
 213                                         syntax_error("Too many buttons (9)", keys);     /* #### this leaks */
 214                         }
 215
 216                         prev->next = wv;
 217                         prev = wv;
 218                 }
 219         }
 220
 221         if (n == 0)
 222                 syntax_error("Dialog boxes must have some buttons", keys);
 223
 224         {
 225                 Extbyte type = (text_field_p ? 'P' : 'Q');
 226                 static Extbyte tmp_dbox_name[255];
 227                 widget_value *dbox;
 228                 int sz = snprintf(tmp_dbox_name, sizeof(tmp_dbox_name),
 229                               "%c%dBR%d", type, lbuttons + rbuttons,
 230                               rbuttons);
 231
 232                 assert(sz >= 0 && (size_t)sz < sizeof(tmp_dbox_name));
 233                 dbox = xmalloc_widget_value();
 234                 dbox->name = xstrdup(tmp_dbox_name);
 235                 dbox->contents = kids;
 236
 237                 /* No more need to free the half-filled-in structures. */
 238                 set_opaque_ptr(wv_closure, 0);
 239                 unbind_to(count, Qnil);
 240                 return dbox;
 241         }
 242 }
 243
 244 static Lisp_Object
 245 x_make_dialog_box_internal(struct frame *f, Lisp_Object type, Lisp_Object keys)
 246 {
 247         int dbox_id;
 248         widget_value *data;
 249         Widget parent;
 250
 251         if (!EQ(type, Qquestion))
 252                 signal_type_error(Qunimplemented, "Dialog box type", type);
 253
 254         data = dbox_descriptor_to_widget_value(keys);
 255
 256         parent = FRAME_X_SHELL_WIDGET(f);
 257
 258         dbox_id = new_lwlib_id();
 259
 260         (void)lw_create_widget(data->name, "dialog", dbox_id, data, parent, 1, 0,
 261                                dbox_selection_callback, 0);
 262         lw_modify_all_widgets(dbox_id, data, True);
 263         lw_modify_all_widgets(dbox_id, data->contents, True);
 264         free_popup_widget_value_tree(data);
 265
 266         gcpro_popup_callbacks(dbox_id);
 267
 268         /* Setting zmacs-region-stays is necessary here because executing a
 269            command from a dialog is really a two-command process: the first
 270            command (bound to the button-click) simply pops up the dialog,
 271            and returns.  This causes a sequence of magic-events (destined
 272            for the dialog widget) to begin.  Eventually, a dialog item is
 273            selected, and a misc-user-event blip is pushed onto the end of
 274            the input stream, which is then executed by the event loop.
 275
 276            So there are two command-events, with a bunch of magic-events
 277            between them.  We don't want the *first* command event to alter
 278            the state of the region, so that the region can be available as
 279            an argument for the second command. */
 280         if (zmacs_regions)
 281                 zmacs_region_stays = 1;
 282
 283         popup_up_p++;
 284         lw_pop_up_all_widgets(dbox_id);
 285
 286         /* #### this could (theoretically) cause problems if we are up for
 287            a REALLY REALLY long time -- too big to fit into lisp integer. */
 288         return make_int(dbox_id);
 289 }
 290
 291 void syms_of_dialog_x(void)
 292 {
 293 }
 294
 295 void console_type_create_dialog_x(void)
 296 {
 297         CONSOLE_HAS_METHOD(x, make_dialog_box_internal);
 298 }
 299
 300 void vars_of_dialog_x(void)
 301 {
 302 #if defined (LWLIB_DIALOGS_MOTIF)
 303         Fprovide(intern("motif-dialogs"));
 304 #elif defined (LWLIB_DIALOGS_ATHENA)
 305         Fprovide(intern("athena-dialogs"));
 306 #endif
 307 }