/* Implements elisp-programmable dialog boxes -- X interface.
Copyright (C) 1993, 1994 Free Software Foundation, Inc.
Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
Copyright (C) 2000, 2002, 2003, 2010 Ben Wing.
This file is part of XEmacs.
XEmacs is free software: you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the
Free Software Foundation, either version 3 of the License, or (at your
option) any later version.
XEmacs is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
for more details.
You should have received a copy of the GNU General Public License
along with XEmacs. If not, see . */
/* Synched up with: Not in FSF. */
/* This file Mule-ized by Ben Wing, 7-8-00. */
#include
#include "lisp.h"
#include "buffer.h"
#include "commands.h" /* zmacs_regions */
#include "events.h"
#include "frame-impl.h"
#include "gui.h"
#include "opaque.h"
#include "window.h"
#include "console-x-impl.h"
#include "EmacsFrame.h"
static void
maybe_run_dbox_text_callback (LWLIB_ID id)
{
widget_value *wv;
int got_some;
wv = xmalloc_widget_value ();
wv->name = xstrdup ("value");
got_some = lw_get_some_values (id, wv);
if (got_some)
{
Lisp_Object text_field_callback;
Extbyte *text_field_value = wv->value;
text_field_callback = GET_LISP_FROM_VOID (wv->call_data);
text_field_callback = XCAR (XCDR (text_field_callback));
if (text_field_value)
{
void *tmp =
STORE_LISP_IN_VOID (cons3 (Qnil,
list2 (text_field_callback,
build_extstring (text_field_value,
Qlwlib_encoding)),
Qnil));
popup_selection_callback (0, id, (XtPointer) tmp);
}
}
/* This code tried to optimize, newing/freeing. This is generally
unsafe so we will always strdup and always use
free_widget_value_tree. */
free_widget_value_tree (wv);
}
static void
dbox_selection_callback (Widget widget, LWLIB_ID id, XtPointer client_data)
{
/* This is called with client_data == -1 when WM_DELETE_WINDOW is sent
instead of a button being selected. */
struct device *d = get_device_from_display (XtDisplay (widget));
struct frame *f = 0;
Widget cur_widget = widget;
/* The parent which is actually connected to our EmacsFrame may be a
ways up the tree. */
while (!f && cur_widget)
{
f = x_any_window_to_frame (d, XtWindow (cur_widget));
cur_widget = XtParent (cur_widget);
}
if (popup_handled_p (id))
return;
assert (popup_up_p != 0);
ungcpro_popup_callbacks (id);
popup_up_p--;
maybe_run_dbox_text_callback (id);
popup_selection_callback (widget, id, client_data);
/* #### need to error-protect! will do so when i merge in
my working ws */
va_run_hook_with_args (Qdelete_dialog_box_hook, 1, make_fixnum (id));
lw_destroy_all_widgets (id);
/* The Motif dialog box sets the keyboard focus to itself. When it
goes away we have to take care of getting the focus back
ourselves. */
#ifdef EXTERNAL_WIDGET
/* #### Not sure if this special case is necessary. */
if (f && !FRAME_X_EXTERNAL_WINDOW_P (f))
#else
if (f)
#endif
lw_set_keyboard_focus (FRAME_X_SHELL_WIDGET (f), FRAME_X_TEXT_WIDGET (f));
}
static const Extbyte * const button_names [] = {
"button1", "button2", "button3", "button4", "button5",
"button6", "button7", "button8", "button9", "button10" };
static widget_value *
dbox_descriptor_to_widget_value (Lisp_Object keys)
{
/* This function can GC */
int lbuttons = 0, rbuttons = 0;
int partition_seen = 0;
int text_field_p = 0;
int allow_text_p = 1;
widget_value *prev = 0, *kids = 0;
int n = 0;
int count;
Lisp_Object wv_closure, gui_item;
Lisp_Object question = Qnil;
Lisp_Object buttons = Qnil;
/* Lisp_Object title = Qnil; #### currently unused */
{
EXTERNAL_PROPERTY_LIST_LOOP_3 (key, value, keys)
{
if (EQ (key, Q_question))
{
CHECK_STRING (value);
question = value;
}
else if (EQ (key, Q_title))
{
CHECK_STRING (value);
/* title = value; */
}
else if (EQ (key, Q_buttons))
{
CHECK_LIST (value);
buttons = value;
}
else
invalid_constant ("Unrecognized question-dialog keyword", key);
}
}
if (NILP (question))
sferror ("Dialog descriptor provides no question", keys);
/* Inhibit GC during this conversion. The reasons for this are
the same as in menu_item_descriptor_to_widget_value(); see
the large comment above that function. */
count = begin_gc_forbidden ();
kids = prev = xmalloc_widget_value ();
/* Also make sure that we free the partially-created widget_value
tree on Lisp error. */
wv_closure = make_opaque_ptr (kids);
record_unwind_protect (widget_value_unwind, wv_closure);
prev->name = xstrdup ("message");
prev->value = LISP_STRING_TO_EXTERNAL_MALLOC (question, Qlwlib_encoding);
prev->enabled = 1;
{
EXTERNAL_LIST_LOOP_2 (button, buttons)
{
widget_value *wv;
if (NILP (button))
{
if (partition_seen)
sferror ("More than one partition (nil) seen in dbox spec",
keys);
partition_seen = 1;
continue;
}
CHECK_VECTOR (button);
wv = xmalloc_widget_value ();
gui_item = gui_parse_item_keywords (button);
if (!button_item_to_widget_value (Qdialog,
gui_item, wv, allow_text_p, 1, 0, 1))
{
free_widget_value_tree (wv);
continue;
}
if (wv->type == TEXT_TYPE)
{
text_field_p = 1;
allow_text_p = 0; /* only allow one */
}
else /* it's a button */
{
allow_text_p = 0; /* only allow text field at the front */
if (wv->value)
xfree (wv->value);
wv->value = wv->name; /* what a mess... */
wv->name = xstrdup (button_names [n]);
if (partition_seen)
rbuttons++;
else
lbuttons++;
n++;
if (lbuttons > 9 || rbuttons > 9)
sferror ("Too many buttons (9)",
keys); /* #### this leaks */
}
prev->next = wv;
prev = wv;
}
}
if (n == 0)
sferror ("Dialog boxes must have some buttons", keys);
{
Extbyte type = (text_field_p ? 'P' : 'Q');
static Extbyte tmp_dbox_name [255];
widget_value *dbox;
sprintf (tmp_dbox_name, "%c%dBR%d", type, lbuttons + rbuttons, rbuttons);
dbox = xmalloc_widget_value ();
dbox->name = xstrdup (tmp_dbox_name);
dbox->contents = kids;
/* No more need to free the half-filled-in structures. */
set_opaque_ptr (wv_closure, 0);
unbind_to (count);
return dbox;
}
}
static Lisp_Object
x_make_dialog_box_internal (struct frame* f, Lisp_Object type,
Lisp_Object keys)
{
int dbox_id;
widget_value *data;
Widget parent;
if (!EQ (type, Qquestion))
signal_error (Qunimplemented, "Dialog box type", type);
data = dbox_descriptor_to_widget_value (keys);
parent = FRAME_X_SHELL_WIDGET (f);
dbox_id = new_lwlib_id ();
(void) lw_create_widget (data->name, "dialog", dbox_id, data, parent, 1, 0,
dbox_selection_callback, 0);
lw_modify_all_widgets (dbox_id, data, True);
lw_modify_all_widgets (dbox_id, data->contents, True);
free_popup_widget_value_tree (data);
gcpro_popup_callbacks (dbox_id);
/* Setting zmacs-region-stays is necessary here because executing a
command from a dialog is really a two-command process: the first
command (bound to the button-click) simply pops up the dialog,
and returns. This causes a sequence of magic-events (destined
for the dialog widget) to begin. Eventually, a dialog item is
selected, and a misc-user-event blip is pushed onto the end of
the input stream, which is then executed by the event loop.
So there are two command-events, with a bunch of magic-events
between them. We don't want the *first* command event to alter
the state of the region, so that the region can be available as
an argument for the second command. */
if (zmacs_regions)
zmacs_region_stays = 1;
popup_up_p++;
lw_pop_up_all_widgets (dbox_id);
/* #### this could (theoretically) cause problems if we are up for
a REALLY REALLY long time -- too big to fit into lisp integer. */
return make_fixnum (dbox_id);
}
void
syms_of_dialog_x (void)
{
}
void
console_type_create_dialog_x (void)
{
CONSOLE_HAS_METHOD (x, make_dialog_box_internal);
}
void
vars_of_dialog_x (void)
{
#if defined (LWLIB_DIALOGS_LUCID)
Fprovide (intern ("lucid-dialogs"));
#elif defined (LWLIB_DIALOGS_MOTIF)
Fprovide (intern ("motif-dialogs"));
#elif defined (LWLIB_DIALOGS_ATHENA)
Fprovide (intern ("athena-dialogs"));
#endif
}