This is menubar-x.c in view mode; [Download] [Up]
/* Implements an elisp-programmable menubar -- X interface.
Copyright (C) 1993, 1994 Free Software Foundation, Inc.
Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
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 2, 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; see the file COPYING. If not, write to the Free
Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
/* Synched up with: Not in FSF. */
/* created 16-dec-91 by jwz */
#include <config.h>
#include "lisp.h"
#include "device-x.h"
#include "frame-x.h"
#ifdef LWLIB_USES_MOTIF
#include <Xm/Xm.h> /* for XmVersion */
#endif
#include "EmacsManager.h"
#include "EmacsFrame.h"
#include "EmacsShell.h"
#include "lwlib.h"
#include "buffer.h"
#include "commands.h" /* zmacs_regions */
#include "events.h"
#include "opaque.h"
#include "window.h"
#define HAVE_DIALOG_BOXES
static int set_frame_menubar (struct frame *f,
int deep_p,
int first_time_p);
void free_frame_menubar (struct frame *f);
LWLIB_ID new_lwlib_id (void);
extern int menubar_show_keybindings;
extern Lisp_Object Vmenubar_configuration;
/* we need a unique id for each popup menu and dialog box */
static unsigned int lwlib_id_tick;
/* count of menus/dboxes currently up */
int popup_menu_up_p;
int popup_menu_titles;
extern Lisp_Object Qcurrent_menubar;
extern Lisp_Object Qmenu_no_selection_hook;
extern Lisp_Object Vthis_command_keys; /* event-stream.c */
#define MENUBAR_TYPE 0
#define SUBMENU_TYPE 1
#define POPUP_TYPE 2
LWLIB_ID
new_lwlib_id (void)
{
return ++lwlib_id_tick;
}
/* Converting Lisp menu tree descriptions to lwlib's `widget_value' form.
menu_item_descriptor_to_widget_value() converts a lisp description of a
menubar into a tree of widget_value structures. It allocates widget_values
with malloc_widget_value() and allocates other storage only for the `key'
slot. All other slots are filled with pointers to Lisp_String data. We
allocate a widget_value description of the menu or menubar, and hand it to
lwlib, which then makes a copy of it, which it manages internally. We then
immediately free our widget_value tree; it will not be referenced again.
Incremental menu construction callbacks operate just a bit differently.
They allocate widget_values and call replace_widget_value_tree() to tell
lwlib to destructively modify the incremental stub (subtree) of its
separate widget_value tree.
This function is highly recursive (it follows the menu trees) and may call
eval. The reason we keep pointers to lisp string data instead of copying
it and freeing it later is to avoid the speed penalty that would entail
(since this needs to be fast, in the simple cases at least). (The reason
we malloc/free the keys slot is because there's not a lisp string around
for us to use in that case.)
Since we keep pointers to lisp strings, and we call eval, we could lose if
GC relocates (or frees) those strings. It's not easy to gc protect the
strings because of the recursive nature of this function, and the fact that
it returns a data structure that gets freed later. So... we do the
sleaziest thing possible and inhibit GC for the duration. This is probably
not a big deal...
We do not have to worry about the pointers to Lisp_String data after
this function successfully finishes. lwlib copies all such data with
strdup().
*/
#if 1
/* Eval the activep slot of the menu item */
# define wv_set_evalable_slot(slot,form) \
do { Lisp_Object _f_ = (form); \
slot = (NILP (_f_) ? 0 : \
EQ (_f_, Qt) ? 1 : \
!NILP (Feval (_f_))); \
} while (0)
#else
/* Treat the activep slot of the menu item as a boolean */
# define wv_set_evalable_slot(slot,form) \
slot = (!NILP ((form)))
#endif
widget_value *
xmalloc_widget_value (void)
{
widget_value *tmp = malloc_widget_value ();
if (!tmp) memory_full ();
return tmp;
}
/* menu_item_descriptor_to_widget_value() mallocs a widget_value, but then
may signal lisp errors. If an error does not occur, the opaque ptr we have
here has had its pointer set to 0 to tell us not to do anything.
Otherwise we free the widget value. (This has nothing to do with GC, it's
just about not dropping pointers to malloc'd data when errors happen.)
*/
static Lisp_Object
widget_value_unwind (Lisp_Object closure)
{
widget_value *wv = (widget_value *) get_opaque_ptr (closure);
if (wv)
free_widget_value (wv);
return Qnil;
}
static Boolean
separator_string_p (char *s)
{
char *p, first;
if (!s || s[0] == '\0')
return False;
first = s[0];
if (first != '-' && first != '=')
return False;
for (p = s; *p == first; p++);
if (*p == '!' || *p == ':' || *p == '\0')
return True;
return False;
}
static char *
menu_separator_style (char *s)
{
char *p, first;
if (!s || s[0] == '\0')
return NULL;
first = s[0];
if (first != '-' && first != '=')
return NULL;
for (p = s; *p == first; p++);
/* #### - cannot currently specify a separator tag "--!tag" and a
separator style "--:style" at the same time. */
/* #### - Also, the motif menubar code doesn't deal with the
double etched style yet, so it's not good to get into the habit of
using "===" in menubars to get double-etched lines */
if (*p == '!' || *p == '\0')
return ((first == '-')
? NULL /* single etched is the default */
: xstrdup ("shadowDoubleEtchedIn"));
else if (*p == ':')
return xstrdup (p+1);
return NULL;
}
/* This does the dirty work. gc_currently_forbidden is 1 when this is called.
*/
static int
menu_item_leaf_to_widget_value (Lisp_Object desc, widget_value *wv,
int allow_text_field_p, int no_keys_p)
{
/* !!#### This function has not been Mule-ized */
/* This function cannot GC because gc_currently_forbidden is set when
it's called */
Lisp_Object name = Qnil;
Lisp_Object callback = Qnil;
Lisp_Object suffix = Qnil;
Lisp_Object active_p = Qt;
Lisp_Object include_p = Qt;
Lisp_Object selected_p = Qnil;
Lisp_Object keys = Qnil;
Lisp_Object style = Qnil;
Lisp_Object config_tag = Qnil;
int length = vector_length (XVECTOR (desc));
Lisp_Object *contents = vector_data (XVECTOR (desc));
int plist_p;
int selected_spec = 0, included_spec = 0;
if (length < 3)
signal_simple_error ("button descriptors must be at least 3 long", desc);
/* length 3: [ "name" callback active-p ]
length 4: [ "name" callback active-p suffix ]
or [ "name" callback keyword value ]
length 5+: [ "name" callback [ keyword value ]+ ]
*/
plist_p = (length >= 5 || KEYWORDP (contents [2]));
if (!plist_p)
/* the old way */
{
name = contents [0];
callback = contents [1];
active_p = contents [2];
if (length == 4)
suffix = contents [3];
}
else
{
/* the new way */
int i;
if (length & 1)
signal_simple_error (
"button descriptor has an odd number of keywords and values",
desc);
name = contents [0];
callback = contents [1];
for (i = 2; i < length;)
{
Lisp_Object key = contents [i++];
Lisp_Object val = contents [i++];
if (!KEYWORDP (key))
signal_simple_error_2 ("not a keyword", key, desc);
if (EQ (key, Q_active)) active_p = val;
else if (EQ (key, Q_suffix)) suffix = val;
else if (EQ (key, Q_keys)) keys = val;
else if (EQ (key, Q_style)) style = val;
else if (EQ (key, Q_selected)) selected_p = val, selected_spec = 1;
else if (EQ (key, Q_included)) include_p = val, included_spec = 1;
else if (EQ (key, Q_config)) config_tag = val;
else if (EQ (key, Q_filter))
signal_simple_error(":filter keyword not permitted on leaf nodes", desc);
else
signal_simple_error_2 ("unknown menu item keyword", key, desc);
}
}
if ((!NILP (config_tag) && NILP (Fmemq (config_tag, Vmenubar_configuration)))
|| (included_spec && NILP (Feval (include_p))))
{
/* the include specification says to ignore this item. */
return 0;
}
CHECK_STRING (name, 0);
wv->name = (char *) string_data (XSTRING (name));
if (!NILP (suffix))
{
CHECK_STRING (suffix, 0);
wv->value = xstrdup((char *) string_ext_data (XSTRING (suffix)));
}
wv_set_evalable_slot (wv->enabled, active_p);
wv_set_evalable_slot (wv->selected, selected_p);
wv->call_data = LISP_TO_VOID (callback);
if (no_keys_p || !menubar_show_keybindings)
wv->key = 0;
else if (!NILP (keys)) /* Use this string to generate key bindings */
{
CHECK_STRING (keys, 0);
keys = Fsubstitute_command_keys (keys);
if (string_length (XSTRING (keys)) > 0)
wv->key = xstrdup ((char *) string_data (XSTRING (keys)));
else
wv->key = 0;
}
else if (SYMBOLP (callback)) /* Show the binding of this command. */
{
char buf [1024];
/* #### Warning, dependency here on current_buffer and point */
where_is_to_char (callback, buf);
if (buf [0])
wv->key = xstrdup (buf);
else
wv->key = 0;
}
CHECK_SYMBOL (style, 0);
if (NILP (style))
{
/* If the callback is nil, treat this item like unselectable text.
This way, dashes will show up as a separator. */
if (!wv->enabled)
wv->type = BUTTON_TYPE;
if (separator_string_p (wv->name))
{
wv->type = SEPARATOR_TYPE;
wv->value = menu_separator_style (wv->name);
}
else
{
#if 0
/* #### - this is generally desirable for menubars, but it breaks
a package that uses dialog boxes and next_command_event magic
to use the callback slot in dialog buttons for data instead of
a real callback.
Code is data, right? The beauty of LISP abuse. --Stig */
if (NILP (callback))
wv->type = TEXT_TYPE;
else
#endif
wv->type = BUTTON_TYPE;
}
}
else if (EQ (style, Qbutton))
wv->type = BUTTON_TYPE;
else if (EQ (style, Qtoggle))
wv->type = TOGGLE_TYPE;
else if (EQ (style, Qradio))
wv->type = RADIO_TYPE;
else if (EQ (style, Qtext))
{
wv->type = TEXT_TYPE;
#if 0
wv->value = wv->name;
wv->name = "value";
#endif
}
else
signal_simple_error_2 ("unknown style", style, desc);
if (!allow_text_field_p && (wv->type == TEXT_TYPE))
signal_simple_error ("text field not allowed in this context", desc);
if (selected_spec && EQ (style, Qtext))
signal_simple_error (
":selected only makes sense with :style toggle, radio or button",
desc);
return 1;
}
static widget_value *
menu_item_descriptor_to_widget_value_1 (Lisp_Object desc,
int menu_type, int deep_p,
int filter_p,
int depth)
{
/* This function cannot GC.
It is only called from menu_item_descriptor_to_widget_value, which
prohibits GC. */
/* !!#### This function has not been Mule-ized */
int menubar_root_p = (menu_type == MENUBAR_TYPE && depth == 0);
widget_value *wv;
Lisp_Object wv_closure;
int count = specpdl_depth ();
int partition_seen = 0;
wv = xmalloc_widget_value ();
wv_closure = make_opaque_ptr (wv);
record_unwind_protect (widget_value_unwind, wv_closure);
if (STRINGP (desc))
{
char *string_chars = (char *) string_data (XSTRING (desc));
wv->type = (separator_string_p (string_chars) ? SEPARATOR_TYPE :
TEXT_TYPE);
#if 1
/* #### - should internationalize with X resources instead.
Not so! --ben */
string_chars = GETTEXT (string_chars);
#endif
if (wv->type == SEPARATOR_TYPE)
{
wv->value = menu_separator_style (string_chars);
}
else
{
wv->name = string_chars;
wv->enabled = 1;
}
}
else if (VECTORP (desc))
{
if (!menu_item_leaf_to_widget_value (desc, wv, 1,
(menu_type == MENUBAR_TYPE
&& depth <= 1)))
{
/* :included form was nil */
wv = NULL;
goto menu_item_done;
}
}
else if (CONSP (desc))
{
Lisp_Object incremental_data = desc;
widget_value *prev = 0;
if (STRINGP (XCAR (desc)))
{
Lisp_Object key, val;
Lisp_Object include_p, hook_fn = Qnil, config_tag = Qnil;
int included_spec = 0;
wv->type = CASCADE_TYPE;
wv->enabled = 1;
wv->name =
(char *) string_data (XSTRING (LISP_GETTEXT (XCAR (desc))));
desc = Fcdr (desc);
while (key = Fcar (desc), KEYWORDP (key))
{
Lisp_Object cascade = desc;
desc = Fcdr (desc);
if (NILP (desc))
signal_simple_error ("keyword in menu lacks a value",
cascade);
val = Fcar (desc);
desc = Fcdr (desc);
if (EQ (key, Q_included))
include_p = val, included_spec = 1;
else if (EQ (key, Q_config))
config_tag = val;
else if (EQ (key, Q_filter))
hook_fn = val;
else
signal_simple_error ("unknown menu cascade keyword", cascade);
}
if ((!NILP (config_tag)
&& NILP (Fmemq (config_tag, Vmenubar_configuration)))
|| (included_spec && NILP (Feval (include_p))))
{
wv = NULL;
goto menu_item_done;
}
if (!NILP (hook_fn))
{
#ifdef LWLIB_MENUBARS_LUCID
if (filter_p || depth == 0)
{
#endif
desc = call1 (hook_fn, desc);
#ifdef LWLIB_MENUBARS_LUCID
}
else
{
widget_value *incr_wv = xmalloc_widget_value ();
wv->contents = incr_wv;
incr_wv->type = INCREMENTAL_TYPE;
incr_wv->enabled = 1;
incr_wv->name = wv->name;
/* This is automatically GC protected through
the call to lw_map_widget_values(); no need
to worry. */
incr_wv->call_data = LISP_TO_VOID (incremental_data);
goto menu_item_done;
}
#endif
}
if (menu_type == POPUP_TYPE && popup_menu_titles && depth == 0)
{
/* Simply prepend three more widget values to the contents of
the menu: a label, and two separators (to get a double
line). */
widget_value *title_wv = xmalloc_widget_value ();
widget_value *sep_wv = xmalloc_widget_value ();
title_wv->type = TEXT_TYPE;
title_wv->name = wv->name;
title_wv->enabled = 1;
title_wv->next = sep_wv;
sep_wv->type = SEPARATOR_TYPE;
sep_wv->value = menu_separator_style ("==");
sep_wv->next = 0;
wv->contents = title_wv;
prev = sep_wv;
}
}
else if (menubar_root_p)
{
wv->name = "menubar";
wv->type = CASCADE_TYPE; /* Well, nothing else seems to fit and
this is ignored anyway... */
}
else
{
signal_simple_error ("menu name (first element) must be a string",
desc);
}
wv->enabled = 1;
if (deep_p || menubar_root_p)
{
widget_value *next;
for (; !NILP (desc); desc = Fcdr (desc))
{
Lisp_Object child = Fcar (desc);
if (menubar_root_p && NILP (child)) /* the partition */
{
if (partition_seen)
error (
"more than one partition (nil) in menubar description");
partition_seen = 1;
next = xmalloc_widget_value ();
next->type = PUSHRIGHT_TYPE;
}
else
{
next = menu_item_descriptor_to_widget_value_1 (child,
menu_type,
deep_p,
filter_p,
depth + 1);
}
if (! next)
continue;
else if (prev)
prev->next = next;
else
wv->contents = next;
prev = next;
}
}
if (deep_p && !wv->contents)
wv = NULL;
}
else if (NILP (desc))
error ("nil may not appear in menu descriptions");
else
signal_simple_error ("unrecognized menu descriptor", desc);
menu_item_done:
if (wv)
{
/* Completed normally. Clear out the object that widget_value_unwind()
will be called with to tell it not to free the wv (as we are
returning it.) */
set_opaque_ptr (wv_closure, 0);
}
unbind_to (count, Qnil);
return wv;
}
#if 0
static void
print_widget_value (widget_value *wv, int depth)
{
/* !!#### This function has not been Mule-ized */
char d [200];
int i;
for (i = 0; i < depth; i++) d[i] = ' ';
d[depth]=0;
/* #### - print type field */
printf ("%sname: %s\n", d, (wv->name ? wv->name : "(null)"));
if (wv->value) printf ("%svalue: %s\n", d, wv->value);
if (wv->key) printf ("%skey: %s\n", d, wv->key);
printf ("%senabled: %d\n", d, wv->enabled);
if (wv->contents)
{
printf ("\n%scontents: \n", d);
print_widget_value (wv->contents, depth + 5);
}
if (wv->next)
{
printf ("\n");
print_widget_value (wv->next, depth);
}
}
#endif
static widget_value *
menu_item_descriptor_to_widget_value (Lisp_Object desc,
int menu_type, /* if this is a menubar,
popup or sub menu */
int deep_p, /* */
int filter_p) /* if :filter forms
should run now */
{
widget_value *wv;
int count = specpdl_depth ();
record_unwind_protect (restore_gc_inhibit,
make_number (gc_currently_forbidden));
gc_currently_forbidden = 1;
/* Can't GC! */
wv = menu_item_descriptor_to_widget_value_1 (desc, menu_type, deep_p,
filter_p, 0);
unbind_to (count, Qnil);
return wv;
}
/* This recursively calls free_widget_value() on the tree of widgets.
It must free all data that was malloc'ed for these widget_values.
It used to be that emacs only allocated new storage for the `key' slot.
All other slots are pointers into the data of Lisp_Strings, and must be
left alone. */
static void
free_menubar_widget_value_tree (widget_value *wv)
{
if (! wv) return;
if (wv->key) xfree (wv->key);
if (wv->value) xfree (wv->value);
wv->name = wv->value = wv->key = (char *) 0xDEADBEEF;
if (wv->contents && (wv->contents != (widget_value*)1))
{
free_menubar_widget_value_tree (wv->contents);
wv->contents = (widget_value *) 0xDEADBEEF;
}
if (wv->next)
{
free_menubar_widget_value_tree (wv->next);
wv->next = (widget_value *) 0xDEADBEEF;
}
free_widget_value (wv);
}
/* There is exactly one of these per frame.
It doesn't really need to be an lrecord (it's not lisp-accessible)
but it makes marking slightly more modular.
*/
struct menubar_data
{
struct lcrecord_header header;
/* lwlib ID of the tree of widgets corresponding to this menubar.
We pass this to lw_map_widget_values() to retrieve all of our
Lispy call-data values that need to be GCPRO'd. */
LWLIB_ID id;
/* This is the last buffer for which the menubar was displayed.
If the buffer has changed, we may have to update things. */
Lisp_Object last_menubar_buffer;
/* This flag tells us if the menubar contents are up-to-date with respect
to the current menubar structure. If we want to actually pull down a
menu and this is false, then we need to update things. */
char menubar_contents_up_to_date;
};
DECLARE_LRECORD (menubar_data, struct menubar_data);
#define XMENUBAR_DATA(x) XRECORD (x, menubar_data, struct menubar_data)
#define XSETMENUBAR_DATA(x, p) XSETRECORD (x, p, menubar_data)
#define MENUBAR_DATAP(x) RECORDP (x, menubar_data)
#define CHECK_MENUBAR_DATA(x, i) CHECK_RECORD (x, menubar_data)
static Lisp_Object mark_menubar_data (Lisp_Object obj,
void (*markobj) (Lisp_Object));
DEFINE_LRECORD_IMPLEMENTATION ("menubar-data", menubar_data,
mark_menubar_data, 0, 0, 0, 0,
struct menubar_data);
struct mark_widget_value_closure
{
void (*markobj) (Lisp_Object);
};
static int
mark_widget_value_mapper (widget_value *val, void *closure)
{
Lisp_Object markee;
struct mark_widget_value_closure *cl =
(struct mark_widget_value_closure *) closure;
if (val->call_data)
{
VOID_TO_LISP (markee, val->call_data);
(cl->markobj) (markee);
}
return 0;
}
static Lisp_Object
mark_menubar_data (Lisp_Object obj, void (*markobj) (Lisp_Object))
{
struct menubar_data *data = (struct menubar_data *) XMENUBAR_DATA (obj);
/* Now mark the callbacks and such that are hidden in the lwlib
call-data */
if (data->id)
{
struct mark_widget_value_closure closure;
closure.markobj = markobj;
lw_map_widget_values (data->id, mark_widget_value_mapper, &closure);
}
return (data->last_menubar_buffer);
}
#define FRAME_MENUBAR_DATA(frame) \
((struct menubar_data *) XMENUBAR_DATA ((frame)->menubar_data))
/* This is like FRAME_MENUBAR_DATA (f), but contains an alist of
(id . menubar-data) for GCPRO'ing the callbacks of the popup menus
and dialog boxes. */
static Lisp_Object Vpopup_callbacks;
static void
gcpro_popup_callbacks (LWLIB_ID id)
{
struct menubar_data *mdata;
Lisp_Object lid = make_number (id);
Lisp_Object lmdata = Qnil;
assert (NILP (assq_no_quit (lid, Vpopup_callbacks)));
mdata = alloc_lcrecord (sizeof (struct menubar_data), lrecord_menubar_data);
mdata->id = id;
mdata->last_menubar_buffer = Qnil;
mdata->menubar_contents_up_to_date = 0;
XSETMENUBAR_DATA (lmdata, mdata);
Vpopup_callbacks = Fcons (Fcons (lid, lmdata), Vpopup_callbacks);
}
static void
ungcpro_popup_callbacks (LWLIB_ID id)
{
Lisp_Object lid = make_number (id);
Lisp_Object this = assq_no_quit (lid, Vpopup_callbacks);
assert (!NILP (this));
Vpopup_callbacks = delq_no_quit (this, Vpopup_callbacks);
}
/* The order in which callbacks are run is funny to say the least.
It's sometimes tricky to avoid running a callback twice, and to
avoid returning prematurely. So, this function returns true
if the menu's callbacks are no longer gc protected. So long
as we unprotect them before allowing other callbacks to run,
everything should be ok.
The pre_activate_callback() *IS* intentionally called multiple times.
If client_data == NULL, then it's being called before the menu is posted.
If client_data != NULL, then client_data is a (widget_value *) and
client_data->data is a Lisp_Object pointing to a lisp submenu description
that must be converted into widget_values. *client_data is destructively
modified.
#### Stig thinks that there may be a GC problem here due to the
fact that pre_activate_callback() is called multiple times, but I
think he's wrong.
*/
static int
popup_handled_p (LWLIB_ID id)
{
return (NILP (assq_no_quit (make_number (id), Vpopup_callbacks)));
}
extern Lisp_Object Vactivate_menubar_hook;
static void
pre_activate_callback (Widget widget, LWLIB_ID id, XtPointer client_data)
{
/* This function can GC */
struct gcpro gcpro1;
struct device *d = get_device_from_display (XtDisplay (widget));
struct frame *f = x_any_window_to_frame (d, XtWindow (widget));
Lisp_Object rest = Qnil;
int any_changes = 0;
if (!f)
f = x_any_window_to_frame (d, XtWindow (XtParent (widget)));
if (!f)
return;
if (client_data)
{
/* this is an incremental menu construction callback */
widget_value *hack_wv = (widget_value *) client_data;
Lisp_Object submenu_desc;
widget_value *wv;
assert (hack_wv->type == INCREMENTAL_TYPE);
VOID_TO_LISP (submenu_desc, hack_wv->call_data);
wv = menu_item_descriptor_to_widget_value (submenu_desc, SUBMENU_TYPE,
1, 1);
if (!wv)
{
wv = xmalloc_widget_value ();
wv->type = CASCADE_TYPE;
wv->next = NULL;
wv->contents = xmalloc_widget_value ();
wv->contents->type = TEXT_TYPE;
wv->contents->name = "No menu";
wv->contents->next = NULL;
}
assert (wv && wv->type == CASCADE_TYPE && wv->contents);
replace_widget_value_tree (hack_wv, wv->contents);
free_menubar_widget_value_tree (wv);
}
else
{
if (!MENUBAR_DATAP (f->menubar_data))
return;
/* #### - this menubar update mechanism is expensively anti-social and
the activate-menubar-hook is now mostly obsolete. */
/* make the activate-menubar-hook be a list of functions, not a single
function, just to simplify things. */
if (!NILP (Vactivate_menubar_hook) &&
(!CONSP (Vactivate_menubar_hook) ||
EQ (XCAR (Vactivate_menubar_hook), Qlambda)))
Vactivate_menubar_hook = Fcons (Vactivate_menubar_hook, Qnil);
GCPRO1 (rest);
for (rest = Vactivate_menubar_hook; !NILP (rest); rest = Fcdr (rest))
if (!EQ (call0 (XCAR (rest)), Qt))
any_changes = 1;
#if 0
/* #### - It is necessary to *ALWAYS* call set_frame_menubar() now that
incremental menus are implemented. If a subtree of a menu has been
updated incrementally (a destructive operation), then that subtree
must somehow be wiped.
It is difficult to undo the destructive operation in lwlib because
a pointer back to lisp data needs to be hidden away somewhere. So
that an INCREMENTAL_TYPE widget_value can be recreated... Hmmmmm. */
if (any_changes ||
!FRAME_MENUBAR_DATA (f)->menubar_contents_up_to_date)
#endif
set_frame_menubar (f, 1, 0);
UNGCPRO;
}
}
/* The following is actually called from somewhere within XtDispatchEvent(),
called from XtAppProcessEvent() in event-Xt.c */
static void
menubar_selection_callback (Widget widget, LWLIB_ID ignored_id,
XtPointer client_data)
{
Lisp_Object fn, arg;
Lisp_Object data;
if (((LISP_WORD_TYPE) client_data) == 0)
return;
VOID_TO_LISP (data, client_data);
#if 0
/* #### What the hell? I can't understand why this call is here,
and doing it is really courting disaster in the new event
model, since menubar_selection_callback is called from
within next_event_internal() and Faccept_process_output()
itself calls next_event_internal(). --Ben */
/* Flush the X and process input */
Faccept_process_output (Qnil, Qnil, Qnil);
#endif
if (((LISP_WORD_TYPE) client_data) == -1)
{
fn = Vrun_hooks;
arg = Qmenu_no_selection_hook;
if (NILP (fn))
fn = Qsymbolp; /* something innocuous */
}
else if (SYMBOLP (data))
{
fn = Qcall_interactively;
arg = data;
}
else if (CONSP (data))
{
fn = Qeval;
arg = data;
}
else
{
fn = Qeval;
arg = list3 (Qsignal,
list2 (Qquote, Qerror),
list2 (Qquote, list2 (build_translated_string
("illegal menu callback"),
data)));
}
/* This is the timestamp used for asserting focus so we need to get an
up-to-date value event if no events has been dispatched to emacs
*/
{
struct device *d = get_device_from_display (XtDisplay (widget));
DEVICE_X_MOUSE_TIMESTAMP (d) = DEVICE_X_GLOBAL_MOUSE_TIMESTAMP (d);
}
signal_special_Xt_user_event (fn, arg);
}
#ifdef ENERGIZE
extern int *get_psheets_for_buffer (Lisp_Object, int *);
static void
set_panel_button_sensitivity (struct frame *f, widget_value *data)
{
struct window *window = XWINDOW (f->selected_window);
int current_buffer_psheets_count = 0;
int *current_buffer_psheets =
get_psheets_for_buffer (window->buffer, ¤t_buffer_psheets_count);
int panel_enabled = FRAME_X_DESIRED_PSHEETS (f) ||
current_buffer_psheets_count;
widget_value *val;
for (val = data->contents; val; val = val->next)
if (val->name && !strcmp (val->name, "sheet"))
{
val->enabled = panel_enabled;
return;
}
}
#endif /* ENERGIZE */
static widget_value*
compute_menubar_data (struct frame *f, Lisp_Object menubar, int deep_p)
{
widget_value *data;
if (NILP (menubar))
data = 0;
else
{
data = menu_item_descriptor_to_widget_value (menubar, MENUBAR_TYPE,
deep_p, 0);
#ifdef ENERGIZE
if (data)
set_panel_button_sensitivity (f, data);
#endif
}
return data;
}
static Lisp_Object Vblank_menubar;
static int
set_frame_menubar (struct frame *f, int deep_p, int first_time_p)
{
widget_value *data;
Lisp_Object menubar;
int menubar_visible;
long id;
struct window *w = XWINDOW (f->selected_window);
if (! FRAME_IS_X (f))
return 0;
/***** first compute the contents of the menubar *****/
if (! first_time_p)
{
/* evaluate `current-menubar' in the buffer of the selected window
of the frame in question. */
menubar = symbol_value_in_buffer (Qcurrent_menubar, w->buffer);
}
else
{
/* That's a little tricky the first time since the frame isn't
fully initialized yet. */
menubar = Fsymbol_value (Qcurrent_menubar);
}
if (NILP (menubar))
{
menubar = Vblank_menubar;
menubar_visible = 0;
}
else
menubar_visible = !NILP (w->menubar_visible_p);
data = compute_menubar_data (f, menubar, deep_p);
if (!data || (!data->next && !data->contents))
abort ();
if (NILP (f->menubar_data))
{
struct menubar_data *mdata =
alloc_lcrecord (sizeof (struct menubar_data), lrecord_menubar_data);
mdata->id = new_lwlib_id ();
mdata->last_menubar_buffer = Qnil;
mdata->menubar_contents_up_to_date = 0;
XSETMENUBAR_DATA (f->menubar_data, mdata);
}
/***** now store into the menubar widget, creating it if necessary *****/
id = FRAME_MENUBAR_DATA (f)->id;
if (!FRAME_X_MENUBAR_WIDGET (f))
{
Widget parent = FRAME_X_CONTAINER_WIDGET (f);
assert (first_time_p);
/* It's the first time we've mapped the menubar so compute its
contents completely once. This makes sure that the menubar
components are created with the right type. */
if (!deep_p)
{
free_menubar_widget_value_tree (data);
data = compute_menubar_data (f, menubar, 1);
}
FRAME_X_MENUBAR_WIDGET (f) =
lw_create_widget ("menubar", "menubar", id, data, parent,
0, pre_activate_callback,
menubar_selection_callback, 0);
}
else
{
lw_modify_all_widgets (id, data, deep_p ? True : False);
}
free_menubar_widget_value_tree (data);
FRAME_MENUBAR_DATA (f)->menubar_contents_up_to_date = deep_p;
FRAME_MENUBAR_DATA (f)->last_menubar_buffer =
XWINDOW (f->selected_window)->buffer;
return menubar_visible;
}
/* Called from x_create_widgets() to create the inital menubar of a frame
before it is mapped, so that the window is mapped with the menubar already
there instead of us tacking it on later and thrashing the window after it
is visible. */
int
initialize_frame_menubar (struct frame *f)
{
return set_frame_menubar (f, 1, 1);
}
static LWLIB_ID last_popup_selection_callback_id;
static void
popup_selection_callback (Widget widget, LWLIB_ID id, XtPointer client_data)
{
last_popup_selection_callback_id = id;
menubar_selection_callback (widget, id, client_data);
/* lw_destroy_all_widgets() will be called from popup_down_callback() */
}
static void
popup_down_callback (Widget widget, LWLIB_ID id, XtPointer client_data)
{
if (popup_handled_p (id))
return;
assert (popup_menu_up_p != 0);
ungcpro_popup_callbacks (id);
popup_menu_up_p--;
/* if this isn't called immediately after the selection callback, then
there wasn't a menu selection. */
if (id != last_popup_selection_callback_id)
menubar_selection_callback (widget, id, (XtPointer) -1);
lw_destroy_all_widgets (id);
}
#ifdef HAVE_DIALOG_BOXES
static void
maybe_run_dbox_text_callback (LWLIB_ID id)
{
/* !!#### This function has not been Mule-ized */
widget_value *wv;
int got_some;
wv = xmalloc_widget_value ();
wv->name = "value";
got_some = lw_get_some_values (id, wv);
if (got_some)
{
Lisp_Object text_field_callback;
char *text_field_value = wv->value;
VOID_TO_LISP (text_field_callback, wv->call_data);
if (text_field_value)
{
void *tmp = LISP_TO_VOID (list2 (text_field_callback,
build_string (text_field_value)));
menubar_selection_callback (0, id, (XtPointer) tmp);
xfree (text_field_value);
}
}
free_widget_value (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_menu_up_p != 0);
ungcpro_popup_callbacks (id);
popup_menu_up_p--;
maybe_run_dbox_text_callback (id);
menubar_selection_callback (widget, id, client_data);
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 (!FRAME_X_EXTERNAL_WINDOW_P (f) && f)
#else
if (f)
#endif
lw_set_keyboard_focus (FRAME_X_SHELL_WIDGET (f), FRAME_X_TEXT_WIDGET (f));
}
#endif /* HAVE_DIALOG_BOXES */
static void
make_dummy_xbutton_event (XEvent *dummy,
Widget daddy,
struct Lisp_Event *eev)
/* NULL for eev means query pointer */
{
XButtonPressedEvent *btn = (XButtonPressedEvent *) dummy;
btn->type = ButtonPress;
btn->serial = 0;
btn->send_event = 0;
btn->display = XtDisplay (daddy);
btn->window = XtWindow (daddy);
if (eev)
{
Position shellx, shelly, framex, framey;
Widget shell = XtParent (daddy);
btn->time = eev->timestamp;
btn->button = eev->event.button.button;
btn->root = RootWindowOfScreen (XtScreen (daddy));
btn->subwindow = (Window) NULL;
btn->x = eev->event.button.x;
btn->y = eev->event.button.y;
XtVaGetValues (shell, XtNx, &shellx, XtNy, &shelly, NULL);
XtVaGetValues (daddy, XtNx, &framex, XtNy, &framey, NULL);
btn->x_root = shellx + framex + btn->x;
btn->y_root = shelly + framey + btn->y;;
btn->state = ButtonPressMask; /* all buttons pressed */
}
else
{
/* CurrentTime is just ZERO, so it's worthless for
determining relative click times. */
struct device *d = get_device_from_display (XtDisplay (daddy));
btn->time = DEVICE_X_MOUSE_TIMESTAMP (d); /* event-Xt maintains this */
btn->button = 0;
XQueryPointer (btn->display, btn->window, &btn->root,
&btn->subwindow, &btn->x_root, &btn->y_root,
&btn->x, &btn->y, &btn->state);
}
}
DEFUN ("popup-menu", Fpopup_menu, Spopup_menu, 1, 2, 0,
"Pop up the given menu.\n\
A menu description is a list of menu items, strings, and submenus.\n\
\n\
The first element of a menu must be a string, which is the name of the menu.\n\
This is the string that will be displayed in the parent menu, if any. For\n\
toplevel menus, it is ignored. This string is not displayed in the menu\n\
itself.\n\
\n\
If an element of a menu is a string, then that string will be presented in\n\
the menu as unselectable text.\n\
\n\
If an element of a menu is a string consisting solely of hyphens, then that\n\
item will be presented as a solid horizontal line.\n\
\n\
If an element of a menu is a list, it is treated as a submenu. The name of\n\
that submenu (the first element in the list) will be used as the name of the\n\
item representing this menu on the parent.\n\
\n\
Otherwise, the element must be a vector, which describes a menu item.\n\
A menu item can have any of the following forms:\n\
\n\
[ \"name\" callback <active-p> ]\n\
[ \"name\" callback <active-p> \"suffix\" ]\n\
[ \"name\" callback :<keyword> <value> :<keyword> <value> ... ]\n\
\n\
The name is the string to display on the menu; it is filtered through the\n\
resource database, so it is possible for resources to override what string\n\
is actually displayed.\n\
\n\
If the `callback' of a menu item is a symbol, then it must name a command.\n\
It will be invoked with `call-interactively'. If it is a list, then it is\n\
evaluated with `eval'.\n\
\n\
The possible keywords are this:\n\
\n\
:active <form> Same as <active-p> in the first two forms: the\n\
expression is evaluated just before the menu is\n\
displayed, and the menu will be selectable only if\n\
the result is non-nil.\n\
\n\
:suffix \"string\" Same as \"suffix\" in the second form: the suffix is\n\
appended to the displayed name, providing a convenient\n\
way of adding the name of a command's ``argument'' to\n\
the menu, like ``Kill Buffer NAME''.\n\
\n\
:keys \"string\" Normally, the keyboard equivalents of commands in\n\
menus are displayed when the `callback' is a symbol.\n\
This can be used to specify keys for more complex menu\n\
items. It is passed through `substitute-command-keys'\n\
first.\n\
\n\
:style <style> Specifies what kind of object this menu item is:\n\
\n\
nil A normal menu item.\n\
toggle A toggle button.\n\
radio A radio button.\n\
\n\
The only difference between toggle and radio buttons is\n\
how they are displayed. But for consistency, a toggle\n\
button should be used when there is one option whose\n\
value can be turned on or off, and radio buttons should\n\
be used when there is a set of mutally exclusive\n\
options. When using a group of radio buttons, you\n\
should arrange for no more than one to be marked as\n\
selected at a time.\n\
\n\
:selected <form> Meaningful only when STYLE is `toggle' or `radio'.\n\
This specifies whether the button will be in the\n\
selected or unselected state.\n\
\n\
For example:\n\
\n\
[ \"Save As...\" write-file t ]\n\
[ \"Revert Buffer\" revert-buffer (buffer-modified-p) ]\n\
[ \"Read Only\" toggle-read-only :style toggle :selected buffer-read-only ]\n\
\n\
See menubar.el for many more examples.")
(menu_desc, event)
Lisp_Object menu_desc, event;
{
int menu_id;
struct frame *f = selected_frame ();
widget_value *data;
Widget parent;
Widget menu;
struct Lisp_Event *eev = NULL;
XEvent xev;
if (!FRAME_IS_X (f))
error ("not an X frame");
else
parent = FRAME_X_SHELL_WIDGET (f);
if (!NILP (event))
{
CHECK_LIVE_EVENT (event, 0);
eev= XEVENT (event);
if (eev->event_type != button_press_event
&& eev->event_type != button_release_event)
wrong_type_argument (Qmouse_event_p, event);
}
else if (!NILP (Vthis_command_keys))
{
/* if an event wasn't passed, use the last event of the event sequence
currently being executed, if that event is a mouse event */
eev = XEVENT (Vthis_command_keys); /* last event first */
if (eev->event_type != button_press_event
&& eev->event_type != button_release_event)
eev = NULL;
}
make_dummy_xbutton_event (&xev, parent, eev);
if (SYMBOLP (menu_desc))
menu_desc = Fsymbol_value (menu_desc);
CHECK_CONS (menu_desc, 0);
CHECK_STRING (XCAR (menu_desc), 0);
data = menu_item_descriptor_to_widget_value (menu_desc, POPUP_TYPE, 1, 1);
if (! data) error ("no menu");
menu_id = new_lwlib_id ();
menu = lw_create_widget ("popup", "popup" /* data->name */, menu_id, data,
parent, 1, 0,
popup_selection_callback, popup_down_callback);
free_menubar_widget_value_tree (data);
gcpro_popup_callbacks (menu_id);
/* Setting zmacs-region-stays is necessary here because executing a command
from a menu is really a two-command process: the first command (bound to
the button-click) simply pops up the menu, and returns. This causes a
sequence of magic-events (destined for the popup-menu widget) to begin.
Eventually, a menu item is selected, and a menu-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_menu_up_p++;
lw_popup_menu (menu, &xev);
/* this speeds up display of pop-up menus */
XFlush (XtDisplay (parent));
return Qnil;
}
DEFUN ("popup-menu-up-p", Fpopup_menu_up_p, Spopup_menu_up_p, 0, 0, 0,
"Return t if a popup menu is up, nil otherwise.\n\
See `popup-menu'.")
()
{
return popup_menu_up_p ? Qt : Qnil;
}
#ifdef HAVE_DIALOG_BOXES
static CONST char * CONST button_names [] = {
"button1", "button2", "button3", "button4", "button5",
"button6", "button7", "button8", "button9", "button10" };
/* can't have static frame locals because of some broken compilers */
static char tmp_dbox_name [255];
static widget_value *
dbox_descriptor_to_widget_value (Lisp_Object desc)
{
/* !!#### This function has not been Mule-ized */
/* This function can GC */
char *name;
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 = specpdl_depth ();
Lisp_Object wv_closure;
CHECK_CONS (desc, 0);
CHECK_STRING (XCAR (desc), 0);
name = (char *) string_data (XSTRING (LISP_GETTEXT (XCAR (desc))));
desc = XCDR (desc);
if (!CONSP (desc))
error ("dialog boxes must have some buttons");
/* 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. */
record_unwind_protect (restore_gc_inhibit,
make_number (gc_currently_forbidden));
gc_currently_forbidden = 1;
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 = "message";
prev->value = xstrdup (name);
prev->enabled = 1;
for (; !NILP (desc); desc = Fcdr (desc))
{
Lisp_Object button = XCAR (desc);
widget_value *wv;
if (NILP (button))
{
if (partition_seen)
error ("more than one partition (nil) seen in dbox spec");
partition_seen = 1;
continue;
}
CHECK_VECTOR (button, 0);
wv = xmalloc_widget_value ();
if (!menu_item_leaf_to_widget_value (button, wv, allow_text_p, 1))
{
free_widget_value (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 */
wv->value = xstrdup (wv->name); /* what a mess... */
wv->name = (char *) button_names [n];
if (partition_seen)
rbuttons++;
else
lbuttons++;
n++;
if (lbuttons > 9 || rbuttons > 9)
error ("too many buttons (9)"); /* #### this leaks */
}
prev->next = wv;
prev = wv;
}
if (n == 0)
error ("dialog boxes must have some buttons");
{
char type = (text_field_p ? 'P' : 'Q');
widget_value *dbox;
sprintf (tmp_dbox_name, "%c%dBR%d", type, lbuttons + rbuttons, rbuttons);
dbox = xmalloc_widget_value ();
dbox->name = 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, Qnil);
return dbox;
}
}
DEFUN ("popup-dialog-box", Fpopup_dialog_box, Spopup_dialog_box, 1, 1, 0,
"Pop up a dialog box.\n\
A dialog box description is a list.\n\
\n\
The first element of a dialog box must be a string, which is the title or\n\
question.\n\
\n\
The rest of the elements are descriptions of the dialog box's buttons.\n\
Each of these is a vector, the syntax of which is essentially the same as\n\
that of popup menu items. They may have any of the following forms:\n\
\n\
[ \"name\" callback <active-p> ]\n\
[ \"name\" callback <active-p> \"suffix\" ]\n\
[ \"name\" callback :<keyword> <value> :<keyword> <value> ... ]\n\
\n\
The name is the string to display on the button; it is filtered through the\n\
resource database, so it is possible for resources to override what string\n\
is actually displayed.\n\
\n\
If the `callback' of a button is a symbol, then it must name a command.\n\
It will be invoked with `call-interactively'. If it is a list, then it is\n\
evaluated with `eval'.\n\
\n\
One (and only one) of the buttons may be `nil'. This marker means that all\n\
following buttons should be flushright instead of flushleft.\n\
\n\
Though the keyword/value syntax is supported for dialog boxes just as in \n\
popup menus, the only keyword which is both meaningful and fully implemented\n\
for dialog box buttons is `:active'.")
(dbox_desc)
Lisp_Object dbox_desc;
{
int dbox_id;
struct frame *f = selected_frame ();
widget_value *data;
Widget parent, dbox;
if (!FRAME_IS_X (f)) error ("not an X frame");
if (SYMBOLP (dbox_desc))
dbox_desc = Fsymbol_value (dbox_desc);
CHECK_CONS (dbox_desc, 0);
CHECK_STRING (XCAR (dbox_desc), 0);
data = dbox_descriptor_to_widget_value (dbox_desc);
parent = FRAME_X_SHELL_WIDGET (f);
dbox_id = new_lwlib_id ();
dbox = 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_menubar_widget_value_tree (data);
gcpro_popup_callbacks (dbox_id);
/* Setting zmacs-region-stays is necessary here because executing a command
from a menu is really a two-command process: the first command (bound to
the button-click) simply pops up the menu, and returns. This causes a
sequence of magic-events (destined for the popup-menu widget) to begin.
Eventually, a menu item is selected, and a menu-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_menu_up_p++;
lw_pop_up_all_widgets (dbox_id);
return Qnil;
}
#endif /* HAVE_DIALOG_BOXES */
#ifdef ENERGIZE
extern int desired_debuggerpanel_exposed_p;
extern int current_debuggerpanel_exposed_p;
extern int debuggerpanel_sheet;
extern void notify_energize_sheet_hidden (unsigned long);
#endif
/* #### I don't think that the `inhibit_menubar_change' flag
has any real purpose. Its only use seems to be so that
update_frame_menubar() can still update the Energize-specific
windows even when the menubar shouldn't be updated.
Instead of doing it this way, the Energize junk should
be separated out from this function. --Ben */
static void
x_update_frame_menubar_internal (struct frame *f, int inhibit_menubar_change)
{
/* We assume the menubar contents has changed if the global flag is set,
or if the current buffer has changed, or if the menubar has never
been updated before.
*/
int menubar_contents_changed =
(f->menubar_changed
|| NILP (f->menubar_data)
|| (!EQ (FRAME_MENUBAR_DATA (f)->last_menubar_buffer,
XWINDOW (f->selected_window)->buffer)));
int menubar_was_visible = XtIsManaged (FRAME_X_MENUBAR_WIDGET (f));
int menubar_will_be_visible = menubar_was_visible;
int menubar_visibility_changed;
Cardinal new_num_top_widgets = 1; /* for the menubar */
Widget container = FRAME_X_CONTAINER_WIDGET (f);
#ifdef ENERGIZE
int *old_sheets = FRAME_X_CURRENT_PSHEETS (f);
int *new_sheets = FRAME_X_DESIRED_PSHEETS (f);
int old_count = FRAME_X_CURRENT_PSHEET_COUNT (f);
int new_count = FRAME_X_DESIRED_PSHEET_COUNT (f);
Lisp_Object old_buf = FRAME_X_CURRENT_PSHEET_BUFFER (f);
Lisp_Object new_buf = FRAME_X_DESIRED_PSHEET_BUFFER (f);
int psheets_changed = (old_sheets != new_sheets
|| old_count != new_count
|| !EQ (old_buf, new_buf));
int debuggerpanel_changed = (desired_debuggerpanel_exposed_p
!= current_debuggerpanel_exposed_p);
if (desired_debuggerpanel_exposed_p && FRAME_X_TOP_WIDGETS (f) [1] == 0)
/* This happens when the frame was just created. */
debuggerpanel_changed = 1;
FRAME_X_CURRENT_PSHEETS (f) = FRAME_X_DESIRED_PSHEETS (f);
FRAME_X_CURRENT_PSHEET_COUNT (f) = FRAME_X_DESIRED_PSHEET_COUNT (f);
FRAME_X_CURRENT_PSHEET_BUFFER (f) = FRAME_X_DESIRED_PSHEET_BUFFER (f);
#endif /* ENERGIZE */
if (menubar_contents_changed && !inhibit_menubar_change)
menubar_will_be_visible = set_frame_menubar (f, 0, 0);
menubar_visibility_changed = menubar_was_visible != menubar_will_be_visible;
if (! (menubar_visibility_changed
#ifdef ENERGIZE
|| psheets_changed || debuggerpanel_changed
#endif
))
return;
/* Set menubar visibility */
if (menubar_visibility_changed)
(menubar_will_be_visible ? XtManageChild : XtUnmanageChild)
(FRAME_X_MENUBAR_WIDGET (f));
#ifdef ENERGIZE
/* Set debugger panel visibility */
if (debuggerpanel_changed)
{
Widget w;
int sheet = debuggerpanel_sheet;
w = lw_get_widget (sheet, container, 0);
if (desired_debuggerpanel_exposed_p)
{
if (! w)
w = lw_make_widget (sheet, container, 0);
FRAME_X_TOP_WIDGETS (f)[1] = w;
XtManageChild (w);
}
else
{
notify_energize_sheet_hidden (sheet);
if (w)
XtUnmanageChild (w);
}
}
/* Set psheet visibility. For the moment we just unmanage all the old
ones, and then manage all the new ones. If the number of psheets
ever becomes a large number (i.e. > 1), then we can worry about a
more sophisticated way of doing this. */
if (psheets_changed)
{
int i;
Widget w;
unsigned long sheet;
for (i=0; i<old_count; i++)
{
sheet = old_sheets[i];
w = lw_get_widget (sheet, container, 0);
notify_energize_sheet_hidden (sheet);
if (w)
XtUnmanageChild (w);
}
for (i=0; i<new_count; i++)
{
sheet = new_sheets[i];
/* #### This unconditional call to lw_make_widget() is a bad
idea. Doesn't it cause a memory leak if the widget
already exists?
#### How does Energize know that a sheet just got displayed?
#### Energize knows all. */
w = lw_make_widget (sheet, container, 0);
FRAME_X_TOP_WIDGETS (f)[2+i] = w;
XtManageChild (w);
}
}
new_num_top_widgets += 1+new_count;
#endif /* ENERGIZE */
/* Note that new_num_top_widgets doesn't need to reflect the actual
number of top widgets, but just the limit of FRAME_X_TOP_WIDGETS (f)[]. */
FRAME_X_NUM_TOP_WIDGETS (f) = new_num_top_widgets;
{
/* We want to end up as close in size as possible to what we
were before. So, ask the EmacsManager what size it wants
to be (suggesting the current size), and resize it to that
size. It in turn will call our query-geometry callback,
which will round the size to something that exactly fits
the text widget. */
XtWidgetGeometry req, repl;
req.request_mode = CWWidth | CWHeight;
XtVaGetValues (container,
XtNwidth, &req.width,
XtNheight, &req.height,
0);
XtQueryGeometry (container, &req, &repl);
EmacsManagerChangeSize (container, repl.width,
repl.height);
/* The window size might not have changed but the text size
did; thus, the base size might be incorrect. So update
it. */
EmacsShellUpdateSizeHints (FRAME_X_SHELL_WIDGET (f));
}
#ifdef ENERGIZE
/* Give back the focus to emacs if no psheets are displayed anymore */
if (psheets_changed)
{
Lisp_Object frame;
XSETFRAME (frame, f);
Fselect_frame (frame);
}
#endif /* ENERGIZE */
}
static void
x_update_frame_menubars (struct frame *f)
{
assert (FRAME_IS_X (f));
/* The minibuffer does not have its own menubar, but uses whatever
menubar is already there. This avoids unseemly menubar
flashing. */
if (MINI_WINDOW_P (XWINDOW (f->selected_window)))
x_update_frame_menubar_internal (f, 1);
else
x_update_frame_menubar_internal (f, 0);
/* #### This isn't going to work right now that this function works on
a per-frame, not per-device basis. Guess what? I don't care. */
#ifdef ENERGIZE
current_debuggerpanel_exposed_p = desired_debuggerpanel_exposed_p;
#endif
}
void
free_frame_menubar (struct frame *f) /* called from delete_frame_internal */
{
Widget menubar_widget;
if (! FRAME_IS_X (f))
return;
menubar_widget = FRAME_X_MENUBAR_WIDGET (f);
if (menubar_widget)
{
LWLIB_ID id = FRAME_MENUBAR_DATA (f)->id;
lw_destroy_all_widgets (id);
FRAME_MENUBAR_DATA (f)->id = 0;
}
#ifdef ENERGIZE
{
/* Also destroy this frame's psheets */
Widget parent = FRAME_X_CONTAINER_WIDGET (f);
int *sheets = FRAME_X_CURRENT_PSHEETS (f);
int i = FRAME_X_CURRENT_PSHEET_COUNT (f);
while (i--)
{
unsigned long sheet = sheets [i];
Widget w = lw_get_widget (sheet, parent, 0);
if (w)
lw_destroy_widget (w);
}
FRAME_X_CURRENT_PSHEET_COUNT (f) = 0;
/* Is this necessary? */
sheets = FRAME_X_DESIRED_PSHEETS (f);
i = FRAME_X_DESIRED_PSHEET_COUNT (f);
while (i--)
{
unsigned long sheet = sheets [i];
Widget w = lw_get_widget (sheet, parent, 0);
if (w)
lw_destroy_widget (w);
}
FRAME_X_DESIRED_PSHEET_COUNT (f) = 0;
/* sigh... debugger panel is special... */
if (debuggerpanel_sheet)
{
Widget w = lw_get_widget (debuggerpanel_sheet, parent, 0);
if (w)
lw_destroy_widget (w);
}
}
#endif /* ENERGIZE */
}
/* This is a kludge to make sure emacs can only link against a version of
lwlib that was compiled in the right way. Emacs references symbols which
correspond to the way it thinks lwlib was compiled, and if lwlib wasn't
compiled in that way, then somewhat meaningful link errors will result.
The alternatives to this range from obscure link errors, to obscure
runtime errors that look a lot like bugs.
*/
static void
sanity_check_lwlib (void)
{
#define MACROLET(v) { extern int v; v = 1; }
#if (XlibSpecificationRelease == 4)
MACROLET (lwlib_uses_x11r4);
#elif (XlibSpecificationRelease == 5)
MACROLET (lwlib_uses_x11r5);
#elif (XlibSpecificationRelease == 6)
MACROLET (lwlib_uses_x11r6);
#else
MACROLET (lwlib_uses_unknown_x11);
#endif
#ifdef LWLIB_USES_MOTIF
MACROLET (lwlib_uses_motif);
#else
MACROLET (lwlib_does_not_use_motif);
#endif
#if (XmVersion >= 1002)
MACROLET (lwlib_uses_motif_1_2);
#else
MACROLET (lwlib_does_not_use_motif_1_2);
#endif
#ifdef LWLIB_MENUBARS_LUCID
MACROLET (lwlib_menubars_lucid);
#else
MACROLET (lwlib_menubars_motif);
#endif
#ifdef LWLIB_SCROLLBARS_LUCID
MACROLET (lwlib_scrollbars_lucid);
#else
# ifdef LWLIB_SCROLLBARS_MOTIF
MACROLET (lwlib_scrollbars_motif);
# else
MACROLET (lwlib_scrollbars_athena);
# endif
#endif
#ifdef LWLIB_DIALOGS_MOTIF
MACROLET (lwlib_dialogs_motif);
#else
MACROLET (lwlib_dialogs_athena);
#endif
#ifdef ENERGIZE
MACROLET (lwlib_uses_energize);
#else
MACROLET (lwlib_does_not_use_energize);
#endif
#undef MACROLET
}
void
syms_of_menubar_x (void)
{
defsubr (&Spopup_menu);
defsubr (&Spopup_menu_up_p);
#ifdef HAVE_DIALOG_BOXES
defsubr (&Spopup_dialog_box);
#endif
}
void
device_type_create_menubar_x (void)
{
DEVICE_HAS_METHOD (x, update_frame_menubars);
}
void
vars_of_menubar_x (void)
{
popup_menu_up_p = 0;
last_popup_selection_callback_id = -1;
lwlib_id_tick = (1<<16); /* start big, to not conflict with Energize */
Vpopup_callbacks = Qnil;
staticpro (&Vpopup_callbacks);
#ifdef HAVE_DIALOG_BOXES
Fprovide (intern ("dialog"));
#endif
{
/* put in Vblank_menubar a menubar value which has no visible
* items. This is a bit tricky due to various quirks. We
* could use '(["" nil nil]), but this is apparently equivalent
* to '(nil), and a new frame created with this menubar will
* get a vertically-squished menubar. If we use " " as the
* button title instead of "", we get an etched button border.
* So we use
* '(("No active menubar" ["" nil nil]))
* which creates a menu whose title is "No active menubar",
* and this works fine.
*/
Lisp_Object menu_item[3];
char *blank_msg = "No active menubar";
menu_item[0] = build_string ("");
menu_item[1] = Qnil;
menu_item[2] = Qnil;
Vblank_menubar = Fcons (Fcons (build_string (blank_msg),
Fcons (Fvector (3, &menu_item[0]),
Qnil)),
Qnil);
Vblank_menubar = Fpurecopy (Vblank_menubar);
staticpro (&Vblank_menubar);
}
DEFVAR_BOOL ("popup-menu-titles", &popup_menu_titles,
"If true, popup menus will have title bars at the top.");
popup_menu_titles = 1;
/* this makes only safe calls as in emacs.c */
sanity_check_lwlib ();
}
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.