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