Lisp_Object
w32_menu_show (struct frame *f, int x, int y, int menuflags,
Lisp_Object title, const char **error)
{
int i;
int menu_item_selection;
HMENU menu;
POINT pos;
widget_value *wv, *save_wv = 0, *first_wv = 0, *prev_wv = 0;
widget_value **submenu_stack
= (widget_value **) alloca (menu_items_used * sizeof (widget_value *));
Lisp_Object *subprefix_stack
= (Lisp_Object *) alloca (menu_items_used * word_size);
int submenu_depth = 0;
bool first_pane;
*error = NULL;
if (menu_items_n_panes == 0)
return Qnil;
if (menu_items_used <= MENU_ITEMS_PANE_LENGTH)
{
*error = "Empty menu";
return Qnil;
}
block_input ();
/* Create a tree of widget_value objects
representing the panes and their items. */
wv = make_widget_value ("menu", NULL, true, Qnil);
wv->button_type = BUTTON_TYPE_NONE;
first_wv = wv;
first_pane = true;
/* Loop over all panes and items, filling in the tree. */
i = 0;
while (i < menu_items_used)
{
if (EQ (AREF (menu_items, i), Qnil))
{
submenu_stack[submenu_depth++] = save_wv;
save_wv = prev_wv;
prev_wv = 0;
first_pane = false;
i++;
}
else if (EQ (AREF (menu_items, i), Qlambda))
{
prev_wv = save_wv;
save_wv = submenu_stack[--submenu_depth];
first_pane = false;
i++;
}
else if (EQ (AREF (menu_items, i), Qt)
&& submenu_depth != 0)
i += MENU_ITEMS_PANE_LENGTH;
/* Ignore a nil in the item list.
It's meaningful only for dialog boxes. */
else if (EQ (AREF (menu_items, i), Qquote))
i += 1;
else if (EQ (AREF (menu_items, i), Qt))
{
/* Create a new pane. */
Lisp_Object pane_name, prefix;
const char *pane_string;
pane_name = AREF (menu_items, i + MENU_ITEMS_PANE_NAME);
prefix = AREF (menu_items, i + MENU_ITEMS_PANE_PREFIX);
if (STRINGP (pane_name))
{
if (unicode_append_menu)
pane_name = ENCODE_UTF_8 (pane_name);
else if (STRING_MULTIBYTE (pane_name))
pane_name = ENCODE_SYSTEM (pane_name);
ASET (menu_items, i + MENU_ITEMS_PANE_NAME, pane_name);
}
pane_string = (NILP (pane_name)
? "" : SSDATA (pane_name));
/* If there is just one top-level pane, put all its items directly
under the top-level menu. */
if (menu_items_n_panes == 1)
pane_string = "";
/* If the pane has a meaningful name,
make the pane a top-level menu item
with its items as a submenu beneath it. */
if (!(menuflags & MENU_KEYMAPS) && strcmp (pane_string, ""))
{
wv = make_widget_value (pane_string, NULL, true, Qnil);
if (save_wv)
save_wv->next = wv;
else
first_wv->contents = wv;
if ((menuflags & MENU_KEYMAPS) && !NILP (prefix))
wv->name++;
wv->button_type = BUTTON_TYPE_NONE;
save_wv = wv;
prev_wv = 0;
}
else if (first_pane)
{
save_wv = wv;
prev_wv = 0;
}
first_pane = false;
i += MENU_ITEMS_PANE_LENGTH;
}
else
{
/* Create a new item within current pane. */
Lisp_Object item_name, enable, descrip, def, type, selected, help;
item_name = AREF (menu_items, i + MENU_ITEMS_ITEM_NAME);
enable = AREF (menu_items, i + MENU_ITEMS_ITEM_ENABLE);
descrip = AREF (menu_items, i + MENU_ITEMS_ITEM_EQUIV_KEY);
def = AREF (menu_items, i + MENU_ITEMS_ITEM_DEFINITION);
type = AREF (menu_items, i + MENU_ITEMS_ITEM_TYPE);
selected = AREF (menu_items, i + MENU_ITEMS_ITEM_SELECTED);
help = AREF (menu_items, i + MENU_ITEMS_ITEM_HELP);
if (STRINGP (item_name))
{
if (unicode_append_menu)
item_name = ENCODE_UTF_8 (item_name);
else if (STRING_MULTIBYTE (item_name))
item_name = ENCODE_SYSTEM (item_name);
ASET (menu_items, i + MENU_ITEMS_ITEM_NAME, item_name);
}
if (STRINGP (descrip) && STRING_MULTIBYTE (descrip))
{
descrip = ENCODE_SYSTEM (descrip);
ASET (menu_items, i + MENU_ITEMS_ITEM_EQUIV_KEY, descrip);
}
wv = make_widget_value (SSDATA (item_name), NULL, !NILP (enable),
STRINGP (help) ? help : Qnil);
if (prev_wv)
prev_wv->next = wv;
else
save_wv->contents = wv;
if (!NILP (descrip))
wv->key = SSDATA (descrip);
/* Use the contents index as call_data, since we are
restricted to 16-bits. */
wv->call_data = !NILP (def) ? (void *) (UINT_PTR) i : 0;
if (NILP (type))
wv->button_type = BUTTON_TYPE_NONE;
else if (EQ (type, QCtoggle))
wv->button_type = BUTTON_TYPE_TOGGLE;
else if (EQ (type, QCradio))
wv->button_type = BUTTON_TYPE_RADIO;
else
emacs_abort ();
wv->selected = !NILP (selected);
prev_wv = wv;
i += MENU_ITEMS_ITEM_LENGTH;
}
}
/* Deal with the title, if it is non-nil. */
if (!NILP (title))
{
widget_value *wv_title;
widget_value *wv_sep = make_widget_value ("--", NULL, false, Qnil);
/* Maybe replace this separator with a bitmap or owner-draw item
so that it looks better. Having two separators looks odd. */
wv_sep->next = first_wv->contents;
if (unicode_append_menu)
title = ENCODE_UTF_8 (title);
else if (STRING_MULTIBYTE (title))
title = ENCODE_SYSTEM (title);
wv_title = make_widget_value (SSDATA (title), NULL, true, Qnil);
wv_title->title = TRUE;
wv_title->button_type = BUTTON_TYPE_NONE;
wv_title->next = wv_sep;
first_wv->contents = wv_title;
}
/* No selection has been chosen yet. */
menu_item_selection = 0;
/* Actually create the menu. */
current_popup_menu = menu = CreatePopupMenu ();
fill_in_menu (menu, first_wv->contents);
/* Adjust coordinates to be root-window-relative. */
pos.x = x;
pos.y = y;
ClientToScreen (FRAME_W32_WINDOW (f), &pos);
/* Display the menu. */
menu_item_selection = SendMessage (FRAME_W32_WINDOW (f),
WM_EMACS_TRACKPOPUPMENU,
(WPARAM)menu, (LPARAM)&pos);
/* Clean up extraneous mouse events which might have been generated
during the call. */
discard_mouse_events ();
FRAME_DISPLAY_INFO (f)->grabbed = 0;
/* Free the widget_value objects we used to specify the contents. */
free_menubar_widget_value_tree (first_wv);
DestroyMenu (menu);
/* Free the owner-drawn and help-echo menu strings. */
w32_free_menu_strings (FRAME_W32_WINDOW (f));
f->output_data.w32->menubar_active = 0;
/* Find the selected item, and its pane, to return
the proper value. */
if (menu_item_selection != 0)
{
Lisp_Object prefix, entry;
prefix = entry = Qnil;
i = 0;
while (i < menu_items_used)
{
if (EQ (AREF (menu_items, i), Qnil))
{
subprefix_stack[submenu_depth++] = prefix;
prefix = entry;
i++;
}
else if (EQ (AREF (menu_items, i), Qlambda))
{
prefix = subprefix_stack[--submenu_depth];
i++;
}
else if (EQ (AREF (menu_items, i), Qt))
{
prefix = AREF (menu_items, i + MENU_ITEMS_PANE_PREFIX);
i += MENU_ITEMS_PANE_LENGTH;
}
/* Ignore a nil in the item list.
It's meaningful only for dialog boxes. */
else if (EQ (AREF (menu_items, i), Qquote))
i += 1;
else
{
entry = AREF (menu_items, i + MENU_ITEMS_ITEM_VALUE);
if (menu_item_selection == i)
{
if (menuflags & MENU_KEYMAPS)
{
int j;
entry = Fcons (entry, Qnil);
if (!NILP (prefix))
entry = Fcons (prefix, entry);
for (j = submenu_depth - 1; j >= 0; j--)
if (!NILP (subprefix_stack[j]))
entry = Fcons (subprefix_stack[j], entry);
}
unblock_input ();
return entry;
}
i += MENU_ITEMS_ITEM_LENGTH;
}
}
}
else if (!(menuflags & MENU_FOR_CLICK))
{
unblock_input ();
/* Make "Cancel" equivalent to C-g. */
Fsignal (Qquit, Qnil);
}
unblock_input ();
return Qnil;
}
static Lisp_Object
simple_dialog_show (struct frame *f, Lisp_Object contents, Lisp_Object header)
{
int answer;
UINT type;
Lisp_Object lispy_answer = Qnil, temp = XCAR (contents);
type = MB_YESNO;
/* Since we only handle Yes/No dialogs, and we already checked
is_simple_dialog, we don't need to worry about checking contents
to see what type of dialog to use. */
/* Use Unicode if possible, so any language can be displayed. */
if (unicode_message_box)
{
WCHAR *text;
const WCHAR *title;
USE_SAFE_ALLOCA;
if (STRINGP (temp))
{
char *utf8_text = SSDATA (ENCODE_UTF_8 (temp));
/* Be pessimistic about the number of characters needed.
Remember characters outside the BMP will take more than
one utf16 word, so we cannot simply use the character
length of temp. */
int utf8_len = strlen (utf8_text);
text = SAFE_ALLOCA ((utf8_len + 1) * sizeof (WCHAR));
utf8to16 ((unsigned char *)utf8_text, utf8_len, text);
}
else
{
text = (WCHAR *)L"";
}
if (NILP (header))
{
title = L"Question";
type |= MB_ICONQUESTION;
}
else
{
title = L"Information";
type |= MB_ICONINFORMATION;
}
answer = unicode_message_box (FRAME_W32_WINDOW (f), text, title, type);
SAFE_FREE ();
}
else
{
const char *text, *title;
/* Fall back on ANSI message box, but at least use system
encoding so questions representable by the system codepage
are encoded properly. */
if (STRINGP (temp))
text = SSDATA (ENCODE_SYSTEM (temp));
else
text = "";
if (NILP (header))
{
title = "Question";
type |= MB_ICONQUESTION;
}
else
{
title = "Information";
type |= MB_ICONINFORMATION;
}
answer = MessageBox (FRAME_W32_WINDOW (f), text, title, type);
}
if (answer == IDYES)
lispy_answer = build_string ("Yes");
else if (answer == IDNO)
lispy_answer = build_string ("No");
else
Fsignal (Qquit, Qnil);
for (temp = XCDR (contents); CONSP (temp); temp = XCDR (temp))
{
Lisp_Object item, name, value;
item = XCAR (temp);
if (CONSP (item))
{
name = XCAR (item);
value = XCDR (item);
}
else
{
name = item;
value = Qnil;
}
if (!NILP (Fstring_equal (name, lispy_answer)))
{
return value;
}
}
Fsignal (Qquit, Qnil);
return Qnil;
}
void
set_frame_menubar (struct frame *f, bool first_time, bool deep_p)
{
HMENU menubar_widget = f->output_data.w32->menubar_widget;
Lisp_Object items;
widget_value *wv, *first_wv, *prev_wv = 0;
int i, last_i;
int *submenu_start, *submenu_end;
int *submenu_top_level_items, *submenu_n_panes;
/* We must not change the menubar when actually in use. */
if (f->output_data.w32->menubar_active)
return;
XSETFRAME (Vmenu_updating_frame, f);
if (! menubar_widget)
deep_p = true;
if (deep_p)
{
/* Make a widget-value tree representing the entire menu trees. */
struct buffer *prev = current_buffer;
Lisp_Object buffer;
ptrdiff_t specpdl_count = SPECPDL_INDEX ();
int previous_menu_items_used = f->menu_bar_items_used;
Lisp_Object *previous_items
= (Lisp_Object *) alloca (previous_menu_items_used
* word_size);
/* If we are making a new widget, its contents are empty,
do always reinitialize them. */
if (! menubar_widget)
previous_menu_items_used = 0;
buffer = XWINDOW (FRAME_SELECTED_WINDOW (f))->contents;
specbind (Qinhibit_quit, Qt);
/* Don't let the debugger step into this code
because it is not reentrant. */
specbind (Qdebug_on_next_call, Qnil);
record_unwind_save_match_data ();
if (NILP (Voverriding_local_map_menu_flag))
{
specbind (Qoverriding_terminal_local_map, Qnil);
specbind (Qoverriding_local_map, Qnil);
}
set_buffer_internal_1 (XBUFFER (buffer));
/* Run the hooks. */
safe_run_hooks (Qactivate_menubar_hook);
safe_run_hooks (Qmenu_bar_update_hook);
fset_menu_bar_items (f, menu_bar_items (FRAME_MENU_BAR_ITEMS (f)));
items = FRAME_MENU_BAR_ITEMS (f);
/* Save the frame's previous menu bar contents data. */
if (previous_menu_items_used)
memcpy (previous_items, XVECTOR (f->menu_bar_vector)->contents,
previous_menu_items_used * word_size);
/* Fill in menu_items with the current menu bar contents.
This can evaluate Lisp code. */
save_menu_items ();
menu_items = f->menu_bar_vector;
menu_items_allocated = VECTORP (menu_items) ? ASIZE (menu_items) : 0;
submenu_start = (int *) alloca (ASIZE (items) * sizeof (int));
submenu_end = (int *) alloca (ASIZE (items) * sizeof (int));
submenu_n_panes = (int *) alloca (ASIZE (items) * sizeof (int));
submenu_top_level_items = (int *) alloca (ASIZE (items) * sizeof (int));
init_menu_items ();
for (i = 0; i < ASIZE (items); i += 4)
{
Lisp_Object key, string, maps;
last_i = i;
key = AREF (items, i);
string = AREF (items, i + 1);
maps = AREF (items, i + 2);
if (NILP (string))
break;
submenu_start[i] = menu_items_used;
menu_items_n_panes = 0;
submenu_top_level_items[i]
= parse_single_submenu (key, string, maps);
submenu_n_panes[i] = menu_items_n_panes;
submenu_end[i] = menu_items_used;
}
finish_menu_items ();
/* Convert menu_items into widget_value trees
to display the menu. This cannot evaluate Lisp code. */
wv = make_widget_value ("menubar", NULL, true, Qnil);
wv->button_type = BUTTON_TYPE_NONE;
first_wv = wv;
for (i = 0; i < last_i; i += 4)
{
menu_items_n_panes = submenu_n_panes[i];
wv = digest_single_submenu (submenu_start[i], submenu_end[i],
submenu_top_level_items[i]);
if (prev_wv)
prev_wv->next = wv;
else
first_wv->contents = wv;
/* Don't set wv->name here; GC during the loop might relocate it. */
wv->enabled = true;
wv->button_type = BUTTON_TYPE_NONE;
prev_wv = wv;
}
set_buffer_internal_1 (prev);
/* If there has been no change in the Lisp-level contents
of the menu bar, skip redisplaying it. Just exit. */
for (i = 0; i < previous_menu_items_used; i++)
if (menu_items_used == i
|| (!EQ (previous_items[i], AREF (menu_items, i))))
break;
if (i == menu_items_used && i == previous_menu_items_used && i != 0)
{
free_menubar_widget_value_tree (first_wv);
discard_menu_items ();
unbind_to (specpdl_count, Qnil);
return;
}
fset_menu_bar_vector (f, menu_items);
f->menu_bar_items_used = menu_items_used;
/* This undoes save_menu_items. */
unbind_to (specpdl_count, Qnil);
/* Now GC cannot happen during the lifetime of the widget_value,
so it's safe to store data from a Lisp_String, as long as
local copies are made when the actual menu is created.
Windows takes care of this for normal string items, but
not for owner-drawn items or additional item-info. */
wv = first_wv->contents;
for (i = 0; i < ASIZE (items); i += 4)
{
Lisp_Object string;
string = AREF (items, i + 1);
if (NILP (string))
break;
wv->name = SSDATA (string);
update_submenu_strings (wv->contents);
wv = wv->next;
}
}
else
{
/* Make a widget-value tree containing
just the top level menu bar strings. */
wv = make_widget_value ("menubar", NULL, true, Qnil);
wv->button_type = BUTTON_TYPE_NONE;
first_wv = wv;
items = FRAME_MENU_BAR_ITEMS (f);
for (i = 0; i < ASIZE (items); i += 4)
{
Lisp_Object string;
string = AREF (items, i + 1);
if (NILP (string))
break;
wv = make_widget_value (SSDATA (string), NULL, true, Qnil);
wv->button_type = BUTTON_TYPE_NONE;
/* This prevents lwlib from assuming this
menu item is really supposed to be empty. */
/* The EMACS_INT cast avoids a warning.
This value just has to be different from small integers. */
wv->call_data = (void *) (EMACS_INT) (-1);
if (prev_wv)
prev_wv->next = wv;
else
first_wv->contents = wv;
prev_wv = wv;
}
/* Forget what we thought we knew about what is in the
detailed contents of the menu bar menus.
Changing the top level always destroys the contents. */
f->menu_bar_items_used = 0;
}
/* Create or update the menu bar widget. */
block_input ();
if (menubar_widget)
{
/* Empty current menubar, rather than creating a fresh one. */
while (DeleteMenu (menubar_widget, 0, MF_BYPOSITION))
;
}
else
{
menubar_widget = CreateMenu ();
}
fill_in_menu (menubar_widget, first_wv->contents);
free_menubar_widget_value_tree (first_wv);
{
HMENU old_widget = f->output_data.w32->menubar_widget;
f->output_data.w32->menubar_widget = menubar_widget;
SetMenu (FRAME_W32_WINDOW (f), f->output_data.w32->menubar_widget);
/* Causes flicker when menu bar is updated
DrawMenuBar (FRAME_W32_WINDOW (f)); */
/* Force the window size to be recomputed so that the frame's text
area remains the same, if menubar has just been created. */
if (old_widget == NULL)
{
windows_or_buffers_changed = 23;
adjust_frame_size (f, -1, -1, 2, false, Qmenu_bar_lines);
}
}
unblock_input ();
}
static void
setup_config (void)
{
const char *coding_name;
const char *cp;
char *end;
int slen;
Lisp_Object coding_system;
Lisp_Object dos_coding_system;
CHECK_SYMBOL (Vselection_coding_system);
coding_system = NILP (Vnext_selection_coding_system) ?
Vselection_coding_system : Vnext_selection_coding_system;
dos_coding_system = validate_coding_system (coding_system);
if (NILP (dos_coding_system))
Fsignal (Qerror,
list2 (build_string ("Coding system is invalid or doesn't have "
"an eol variant for dos line ends"),
coding_system));
/* Check if we have it cached */
if (!NILP (cfg_coding_system)
&& EQ (cfg_coding_system, dos_coding_system))
return;
cfg_coding_system = dos_coding_system;
/* Set some sensible fallbacks */
cfg_codepage = ANSICP;
cfg_lcid = LOCALE_NEUTRAL;
cfg_clipboard_type = CF_TEXT;
/* Interpret the coding system symbol name */
coding_name = SSDATA (SYMBOL_NAME (cfg_coding_system));
/* "(.*-)?utf-16.*" -> CF_UNICODETEXT */
cp = strstr (coding_name, "utf-16");
if (cp != NULL && (cp == coding_name || cp[-1] == '-'))
{
cfg_clipboard_type = CF_UNICODETEXT;
return;
}
/* "cp[0-9]+.*" or "windows-[0-9]+.*" -> CF_TEXT or CF_OEMTEXT */
slen = strlen (coding_name);
if (slen >= 4 && coding_name[0] == 'c' && coding_name[1] == 'p')
cp = coding_name + 2;
else if (slen >= 10 && memcmp (coding_name, "windows-", 8) == 0)
cp = coding_name + 8;
else
return;
end = (char*)cp;
cfg_codepage = strtol (cp, &end, 10);
/* Error return from strtol() or number of digits < 2 -> Restore the
default and drop it. */
if (cfg_codepage == 0 || (end-cp) < 2 )
{
cfg_codepage = ANSICP;
return;
}
/* Is it the currently active system default? */
if (cfg_codepage == ANSICP)
{
/* cfg_clipboard_type = CF_TEXT; */
return;
}
if (cfg_codepage == OEMCP)
{
cfg_clipboard_type = CF_OEMTEXT;
return;
}
/* Else determine a suitable locale the hard way. */
EnumSystemLocales (enum_locale_callback, LCID_INSTALLED);
}
static json_t *
lisp_to_json_toplevel_1 (Lisp_Object lisp)
{
json_t *json;
ptrdiff_t count;
if (VECTORP (lisp))
{
ptrdiff_t size = ASIZE (lisp);
json = json_check (json_array ());
count = SPECPDL_INDEX ();
record_unwind_protect_ptr (json_release_object, json);
for (ptrdiff_t i = 0; i < size; ++i)
{
int status
= json_array_append_new (json, lisp_to_json (AREF (lisp, i)));
if (status == -1)
json_out_of_memory ();
}
eassert (json_array_size (json) == size);
}
else if (HASH_TABLE_P (lisp))
{
struct Lisp_Hash_Table *h = XHASH_TABLE (lisp);
json = json_check (json_object ());
count = SPECPDL_INDEX ();
record_unwind_protect_ptr (json_release_object, json);
for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i)
if (!NILP (HASH_HASH (h, i)))
{
Lisp_Object key = json_encode (HASH_KEY (h, i));
/* We can't specify the length, so the string must be
null-terminated. */
check_string_without_embedded_nulls (key);
const char *key_str = SSDATA (key);
/* Reject duplicate keys. These are possible if the hash
table test is not `equal'. */
if (json_object_get (json, key_str) != NULL)
wrong_type_argument (Qjson_value_p, lisp);
int status = json_object_set_new (json, key_str,
lisp_to_json (HASH_VALUE (h, i)));
if (status == -1)
{
/* A failure can be caused either by an invalid key or
by low memory. */
json_check_utf8 (key);
json_out_of_memory ();
}
}
}
else if (NILP (lisp))
return json_check (json_object ());
else if (CONSP (lisp))
{
Lisp_Object tail = lisp;
json = json_check (json_object ());
count = SPECPDL_INDEX ();
record_unwind_protect_ptr (json_release_object, json);
bool is_plist = !CONSP (XCAR (tail));
FOR_EACH_TAIL (tail)
{
const char *key_str;
Lisp_Object value;
Lisp_Object key_symbol;
if (is_plist)
{
key_symbol = XCAR (tail);
tail = XCDR (tail);
CHECK_CONS (tail);
value = XCAR (tail);
if (EQ (tail, li.tortoise)) circular_list (lisp);
}
else
{
Lisp_Object pair = XCAR (tail);
CHECK_CONS (pair);
key_symbol = XCAR (pair);
value = XCDR (pair);
}
CHECK_SYMBOL (key_symbol);
Lisp_Object key = SYMBOL_NAME (key_symbol);
/* We can't specify the length, so the string must be
null-terminated. */
check_string_without_embedded_nulls (key);
key_str = SSDATA (key);
/* In plists, ensure leading ":" in keys is stripped. It
will be reconstructed later in `json_to_lisp'.*/
if (is_plist && ':' == key_str[0] && key_str[1])
{
key_str = &key_str[1];
}
/* Only add element if key is not already present. */
if (json_object_get (json, key_str) == NULL)
{
int status
= json_object_set_new (json, key_str, lisp_to_json (value));
if (status == -1)
json_out_of_memory ();
}
}
CHECK_LIST_END (tail, lisp);
}
else
static time_t
get_boot_time (void)
{
#if defined (BOOT_TIME)
int counter;
#endif
if (boot_time_initialized)
return boot_time;
boot_time_initialized = 1;
#if defined (CTL_KERN) && defined (KERN_BOOTTIME)
{
int mib[2];
size_t size;
struct timeval boottime_val;
mib[0] = CTL_KERN;
mib[1] = KERN_BOOTTIME;
size = sizeof (boottime_val);
if (sysctl (mib, 2, &boottime_val, &size, NULL, 0) >= 0)
{
boot_time = boottime_val.tv_sec;
return boot_time;
}
}
#endif /* defined (CTL_KERN) && defined (KERN_BOOTTIME) */
if (BOOT_TIME_FILE)
{
struct stat st;
if (stat (BOOT_TIME_FILE, &st) == 0)
{
boot_time = st.st_mtime;
return boot_time;
}
}
#if defined (BOOT_TIME)
#ifndef CANNOT_DUMP
/* The utmp routines maintain static state.
Don't touch that state unless we are initialized,
since it might not survive dumping. */
if (! initialized)
return boot_time;
#endif /* not CANNOT_DUMP */
/* Try to get boot time from utmp before wtmp,
since utmp is typically much smaller than wtmp.
Passing a null pointer causes get_boot_time_1
to inspect the default file, namely utmp. */
get_boot_time_1 (0, 0);
if (boot_time)
return boot_time;
/* Try to get boot time from the current wtmp file. */
get_boot_time_1 (WTMP_FILE, 1);
/* If we did not find a boot time in wtmp, look at wtmp, and so on. */
for (counter = 0; counter < 20 && ! boot_time; counter++)
{
char cmd_string[sizeof WTMP_FILE ".19.gz"];
Lisp_Object tempname, filename;
bool delete_flag = 0;
filename = Qnil;
tempname = make_formatted_string
(cmd_string, "%s.%d", WTMP_FILE, counter);
if (! NILP (Ffile_exists_p (tempname)))
filename = tempname;
else
{
tempname = make_formatted_string (cmd_string, "%s.%d.gz",
WTMP_FILE, counter);
if (! NILP (Ffile_exists_p (tempname)))
{
Lisp_Object args[6];
/* The utmp functions on mescaline.gnu.org accept only
file names up to 8 characters long. Choose a 2
character long prefix, and call make_temp_file with
second arg non-zero, so that it will add not more
than 6 characters to the prefix. */
filename = Fexpand_file_name (build_string ("wt"),
Vtemporary_file_directory);
filename = make_temp_name (filename, 1);
args[0] = build_string ("gzip");
args[1] = Qnil;
args[2] = list2 (QCfile, filename);
args[3] = Qnil;
args[4] = build_string ("-cd");
args[5] = tempname;
Fcall_process (6, args);
delete_flag = 1;
}
}
if (! NILP (filename))
{
get_boot_time_1 (SSDATA (filename), 1);
if (delete_flag)
unlink (SSDATA (filename));
}
}
return boot_time;
#else
return 0;
#endif
}
Lisp_Object
directory_files_internal (Lisp_Object directory, Lisp_Object full, Lisp_Object match, Lisp_Object nosort, int attrs, Lisp_Object id_format)
{
DIR *d;
int directory_nbytes;
Lisp_Object list, dirfilename, encoded_directory;
struct re_pattern_buffer *bufp = NULL;
int needsep = 0;
int count = SPECPDL_INDEX ();
struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
DIRENTRY *dp;
#ifdef WINDOWSNT
Lisp_Object w32_save = Qnil;
#endif
/* Because of file name handlers, these functions might call
Ffuncall, and cause a GC. */
list = encoded_directory = dirfilename = Qnil;
GCPRO5 (match, directory, list, dirfilename, encoded_directory);
dirfilename = Fdirectory_file_name (directory);
if (!NILP (match))
{
CHECK_STRING (match);
/* MATCH might be a flawed regular expression. Rather than
catching and signaling our own errors, we just call
compile_pattern to do the work for us. */
/* Pass 1 for the MULTIBYTE arg
because we do make multibyte strings if the contents warrant. */
# ifdef WINDOWSNT
/* Windows users want case-insensitive wildcards. */
bufp = compile_pattern (match, 0,
BVAR (&buffer_defaults, case_canon_table), 0, 1);
# else /* !WINDOWSNT */
bufp = compile_pattern (match, 0, Qnil, 0, 1);
# endif /* !WINDOWSNT */
}
/* Note: ENCODE_FILE and DECODE_FILE can GC because they can run
run_pre_post_conversion_on_str which calls Lisp directly and
indirectly. */
if (STRING_MULTIBYTE (dirfilename))
dirfilename = ENCODE_FILE (dirfilename);
encoded_directory = (STRING_MULTIBYTE (directory)
? ENCODE_FILE (directory) : directory);
/* Now *bufp is the compiled form of MATCH; don't call anything
which might compile a new regexp until we're done with the loop! */
BLOCK_INPUT;
d = opendir (SSDATA (dirfilename));
UNBLOCK_INPUT;
if (d == NULL)
report_file_error ("Opening directory", Fcons (directory, Qnil));
/* Unfortunately, we can now invoke expand-file-name and
file-attributes on filenames, both of which can throw, so we must
do a proper unwind-protect. */
record_unwind_protect (directory_files_internal_unwind,
make_save_value (d, 0));
#ifdef WINDOWSNT
if (attrs)
{
extern int is_slow_fs (const char *);
/* Do this only once to avoid doing it (in w32.c:stat) for each
file in the directory, when we call Ffile_attributes below. */
record_unwind_protect (directory_files_internal_w32_unwind,
Vw32_get_true_file_attributes);
w32_save = Vw32_get_true_file_attributes;
if (EQ (Vw32_get_true_file_attributes, Qlocal))
{
/* w32.c:stat will notice these bindings and avoid calling
GetDriveType for each file. */
if (is_slow_fs (SDATA (dirfilename)))
Vw32_get_true_file_attributes = Qnil;
else
Vw32_get_true_file_attributes = Qt;
}
}
#endif
directory_nbytes = SBYTES (directory);
re_match_object = Qt;
/* Decide whether we need to add a directory separator. */
if (directory_nbytes == 0
|| !IS_ANY_SEP (SREF (directory, directory_nbytes - 1)))
needsep = 1;
/* Loop reading blocks until EOF or error. */
for (;;)
{
errno = 0;
dp = readdir (d);
if (dp == NULL && (0
#ifdef EAGAIN
|| errno == EAGAIN
#endif
#ifdef EINTR
|| errno == EINTR
#endif
))
{ QUIT; continue; }
if (dp == NULL)
break;
if (DIRENTRY_NONEMPTY (dp))
{
int len;
int wanted = 0;
Lisp_Object name, finalname;
struct gcpro gcpro1, gcpro2;
len = NAMLEN (dp);
name = finalname = make_unibyte_string (dp->d_name, len);
GCPRO2 (finalname, name);
/* Note: DECODE_FILE can GC; it should protect its argument,
though. */
name = DECODE_FILE (name);
len = SBYTES (name);
/* Now that we have unwind_protect in place, we might as well
allow matching to be interrupted. */
immediate_quit = 1;
QUIT;
if (NILP (match)
|| (0 <= re_search (bufp, SSDATA (name), len, 0, len, 0)))
wanted = 1;
immediate_quit = 0;
if (wanted)
{
if (!NILP (full))
{
Lisp_Object fullname;
int nbytes = len + directory_nbytes + needsep;
int nchars;
fullname = make_uninit_multibyte_string (nbytes, nbytes);
memcpy (SDATA (fullname), SDATA (directory),
directory_nbytes);
if (needsep)
SSET (fullname, directory_nbytes, DIRECTORY_SEP);
memcpy (SDATA (fullname) + directory_nbytes + needsep,
SDATA (name), len);
nchars = chars_in_text (SDATA (fullname), nbytes);
/* Some bug somewhere. */
if (nchars > nbytes)
abort ();
STRING_SET_CHARS (fullname, nchars);
if (nchars == nbytes)
STRING_SET_UNIBYTE (fullname);
finalname = fullname;
}
else
finalname = name;
if (attrs)
{
/* Construct an expanded filename for the directory entry.
Use the decoded names for input to Ffile_attributes. */
Lisp_Object decoded_fullname, fileattrs;
struct gcpro gcpro1, gcpro2;
decoded_fullname = fileattrs = Qnil;
GCPRO2 (decoded_fullname, fileattrs);
/* Both Fexpand_file_name and Ffile_attributes can GC. */
decoded_fullname = Fexpand_file_name (name, directory);
fileattrs = Ffile_attributes (decoded_fullname, id_format);
list = Fcons (Fcons (finalname, fileattrs), list);
UNGCPRO;
}
else
list = Fcons (finalname, list);
}
UNGCPRO;
}
}
BLOCK_INPUT;
closedir (d);
UNBLOCK_INPUT;
#ifdef WINDOWSNT
if (attrs)
Vw32_get_true_file_attributes = w32_save;
#endif
/* Discard the unwind protect. */
specpdl_ptr = specpdl + count;
if (NILP (nosort))
list = Fsort (Fnreverse (list),
attrs ? Qfile_attributes_lessp : Qstring_lessp);
RETURN_UNGCPRO (list);
}
static Lisp_Object
parse_region (Lisp_Object start, Lisp_Object end, Lisp_Object base_url, int htmlp)
{
xmlDoc *doc;
Lisp_Object result = Qnil;
const char *burl = "";
ptrdiff_t istart, iend, istart_byte, iend_byte;
fn_xmlCheckVersion (LIBXML_VERSION);
validate_region (&start, &end);
istart = XINT (start);
iend = XINT (end);
istart_byte = CHAR_TO_BYTE (istart);
iend_byte = CHAR_TO_BYTE (iend);
if (istart < GPT && GPT < iend)
move_gap_both (iend, iend_byte);
if (! NILP (base_url))
{
CHECK_STRING (base_url);
burl = SSDATA (base_url);
}
if (htmlp)
doc = fn_htmlReadMemory ((char *) BYTE_POS_ADDR (istart_byte),
iend_byte - istart_byte, burl, "utf-8",
HTML_PARSE_RECOVER|HTML_PARSE_NONET|
HTML_PARSE_NOWARNING|HTML_PARSE_NOERROR|
HTML_PARSE_NOBLANKS);
else
doc = fn_xmlReadMemory ((char *) BYTE_POS_ADDR (istart_byte),
iend_byte - istart_byte, burl, "utf-8",
XML_PARSE_NONET|XML_PARSE_NOWARNING|
XML_PARSE_NOBLANKS |XML_PARSE_NOERROR);
if (doc != NULL)
{
/* If the document is just comments, then this should get us the
nodes anyway. */
xmlNode *n = doc->children->next;
Lisp_Object r = Qnil;
while (n) {
if (!NILP (r))
result = Fcons (r, result);
r = make_dom (n);
n = n->next;
}
if (NILP (result)) {
/* The document isn't just comments, so get the tree the
proper way. */
xmlNode *node = fn_xmlDocGetRootElement (doc);
if (node != NULL)
result = make_dom (node);
} else
result = Fcons (intern ("top"),
Fcons (Qnil, Fnreverse (Fcons (r, result))));
fn_xmlFreeDoc (doc);
}
return result;
}
Lisp_Object
get_doc_string (Lisp_Object filepos, bool unibyte, bool definition)
{
char *from, *to, *name, *p, *p1;
int fd;
ptrdiff_t minsize;
int offset;
EMACS_INT position;
Lisp_Object file, tem, pos;
USE_SAFE_ALLOCA;
if (INTEGERP (filepos))
{
file = Vdoc_file_name;
pos = filepos;
}
else if (CONSP (filepos))
{
file = XCAR (filepos);
pos = XCDR (filepos);
}
else
return Qnil;
position = eabs (XINT (pos));
if (!STRINGP (Vdoc_directory))
return Qnil;
if (!STRINGP (file))
return Qnil;
/* Put the file name in NAME as a C string.
If it is relative, combine it with Vdoc_directory. */
tem = Ffile_name_absolute_p (file);
file = ENCODE_FILE (file);
if (NILP (tem))
{
Lisp_Object docdir = ENCODE_FILE (Vdoc_directory);
minsize = SCHARS (docdir);
/* sizeof ("../etc/") == 8 */
if (minsize < 8)
minsize = 8;
name = SAFE_ALLOCA (minsize + SCHARS (file) + 8);
strcpy (name, SSDATA (docdir));
strcat (name, SSDATA (file));
}
else
{
name = SSDATA (file);
}
fd = emacs_open (name, O_RDONLY, 0);
if (fd < 0)
{
#ifndef CANNOT_DUMP
if (!NILP (Vpurify_flag))
{
/* Preparing to dump; DOC file is probably not installed.
So check in ../etc. */
strcpy (name, "../etc/");
strcat (name, SSDATA (file));
fd = emacs_open (name, O_RDONLY, 0);
}
#endif
if (fd < 0)
return concat3 (build_string ("Cannot open doc string file \""),
file, build_string ("\"\n"));
}
/* Seek only to beginning of disk block. */
/* Make sure we read at least 1024 bytes before `position'
so we can check the leading text for consistency. */
offset = min (position, max (1024, position % (8 * 1024)));
if (TYPE_MAXIMUM (off_t) < position
|| lseek (fd, position - offset, 0) < 0)
{
emacs_close (fd);
error ("Position %"pI"d out of range in doc string file \"%s\"",
position, name);
}
SAFE_FREE ();
/* Read the doc string into get_doc_string_buffer.
P points beyond the data just read. */
p = get_doc_string_buffer;
while (1)
{
ptrdiff_t space_left = (get_doc_string_buffer_size - 1
- (p - get_doc_string_buffer));
int nread;
/* Allocate or grow the buffer if we need to. */
if (space_left <= 0)
{
ptrdiff_t in_buffer = p - get_doc_string_buffer;
get_doc_string_buffer
= xpalloc (get_doc_string_buffer, &get_doc_string_buffer_size,
16 * 1024, -1, 1);
p = get_doc_string_buffer + in_buffer;
space_left = (get_doc_string_buffer_size - 1
- (p - get_doc_string_buffer));
}
/* Read a disk block at a time.
If we read the same block last time, maybe skip this? */
if (space_left > 1024 * 8)
space_left = 1024 * 8;
nread = emacs_read (fd, p, space_left);
if (nread < 0)
{
emacs_close (fd);
error ("Read error on documentation file");
}
p[nread] = 0;
if (!nread)
break;
if (p == get_doc_string_buffer)
p1 = strchr (p + offset, '\037');
else
p1 = strchr (p, '\037');
if (p1)
{
*p1 = 0;
p = p1;
break;
}
p += nread;
}
emacs_close (fd);
/* Sanity checking. */
if (CONSP (filepos))
{
int test = 1;
/* A dynamic docstring should be either at the very beginning of a "#@
comment" or right after a dynamic docstring delimiter (in case we
pack several such docstrings within the same comment). */
if (get_doc_string_buffer[offset - test] != '\037')
{
if (get_doc_string_buffer[offset - test++] != ' ')
return Qnil;
while (get_doc_string_buffer[offset - test] >= '0'
&& get_doc_string_buffer[offset - test] <= '9')
test++;
if (get_doc_string_buffer[offset - test++] != '@'
|| get_doc_string_buffer[offset - test] != '#')
return Qnil;
}
}
else
{
int test = 1;
if (get_doc_string_buffer[offset - test++] != '\n')
return Qnil;
while (get_doc_string_buffer[offset - test] > ' ')
test++;
if (get_doc_string_buffer[offset - test] != '\037')
return Qnil;
}
/* Scan the text and perform quoting with ^A (char code 1).
^A^A becomes ^A, ^A0 becomes a null char, and ^A_ becomes a ^_. */
from = get_doc_string_buffer + offset;
to = get_doc_string_buffer + offset;
while (from != p)
{
if (*from == 1)
{
int c;
from++;
c = *from++;
if (c == 1)
*to++ = c;
else if (c == '0')
*to++ = 0;
else if (c == '_')
*to++ = 037;
else
{
unsigned char uc = c;
error ("\
Invalid data in documentation file -- %c followed by code %03o",
1, uc);
}
}
else
*to++ = *from++;
}
/* If DEFINITION, read from this buffer
the same way we would read bytes from a file. */
if (definition)
{
read_bytecode_pointer = (unsigned char *) get_doc_string_buffer + offset;
return Fread (Qlambda);
}
if (unibyte)
return make_unibyte_string (get_doc_string_buffer + offset,
to - (get_doc_string_buffer + offset));
else
{
/* The data determines whether the string is multibyte. */
ptrdiff_t nchars
= multibyte_chars_in_text (((unsigned char *) get_doc_string_buffer
+ offset),
to - (get_doc_string_buffer + offset));
return make_string_from_bytes (get_doc_string_buffer + offset,
nchars,
to - (get_doc_string_buffer + offset));
}
}
static int
current_lock_owner (lock_info_type *owner, char *lfname)
{
int ret;
ptrdiff_t len;
lock_info_type local_owner;
intmax_t n;
char *at, *dot, *colon;
char readlink_buf[READLINK_BUFSIZE];
char *lfinfo = emacs_readlink (lfname, readlink_buf);
/* If nonexistent lock file, all is well; otherwise, got strange error. */
if (!lfinfo)
return errno == ENOENT ? 0 : -1;
/* Even if the caller doesn't want the owner info, we still have to
read it to determine return value. */
if (!owner)
owner = &local_owner;
/* Parse [email protected]:BOOT_TIME. If can't parse, return -1. */
/* The USER is everything before the last @. */
at = strrchr (lfinfo, '@');
dot = strrchr (lfinfo, '.');
if (!at || !dot)
{
if (lfinfo != readlink_buf)
xfree (lfinfo);
return -1;
}
len = at - lfinfo;
owner->user = xmalloc (len + 1);
memcpy (owner->user, lfinfo, len);
owner->user[len] = 0;
/* The PID is everything from the last `.' to the `:'. */
errno = 0;
n = strtoimax (dot + 1, NULL, 10);
owner->pid =
((0 <= n && n <= TYPE_MAXIMUM (pid_t)
&& (TYPE_MAXIMUM (pid_t) < INTMAX_MAX || errno != ERANGE))
? n : 0);
colon = strchr (dot + 1, ':');
/* After the `:', if there is one, comes the boot time. */
n = 0;
if (colon)
{
errno = 0;
n = strtoimax (colon + 1, NULL, 10);
}
owner->boot_time =
((0 <= n && n <= TYPE_MAXIMUM (time_t)
&& (TYPE_MAXIMUM (time_t) < INTMAX_MAX || errno != ERANGE))
? n : 0);
/* The host is everything in between. */
len = dot - at - 1;
owner->host = xmalloc (len + 1);
memcpy (owner->host, at + 1, len);
owner->host[len] = 0;
/* We're done looking at the link info. */
if (lfinfo != readlink_buf)
xfree (lfinfo);
/* On current host? */
if (STRINGP (Fsystem_name ())
&& strcmp (owner->host, SSDATA (Fsystem_name ())) == 0)
{
if (owner->pid == getpid ())
ret = 2; /* We own it. */
else if (owner->pid > 0
&& (kill (owner->pid, 0) >= 0 || errno == EPERM)
&& (owner->boot_time == 0
|| within_one_second (owner->boot_time, get_boot_time ())))
ret = 1; /* An existing process on this machine owns it. */
/* The owner process is dead or has a strange pid (<=0), so try to
zap the lockfile. */
else if (unlink (lfname) < 0)
ret = -1;
else
ret = 0;
}
else
{ /* If we wanted to support the check for stale locks on remote machines,
here's where we'd do it. */
ret = 1;
}
/* Avoid garbage. */
if (owner == &local_owner || ret <= 0)
{
FREE_LOCK_INFO (*owner);
}
return ret;
}
static Lisp_Object
parse_region (Lisp_Object start, Lisp_Object end, Lisp_Object base_url,
Lisp_Object discard_comments, bool htmlp)
{
xmlDoc *doc;
Lisp_Object result = Qnil;
const char *burl = "";
ptrdiff_t istart, iend, istart_byte, iend_byte;
unsigned char *buftext;
xmlCheckVersion (LIBXML_VERSION);
validate_region (&start, &end);
istart = XINT (start);
iend = XINT (end);
istart_byte = CHAR_TO_BYTE (istart);
iend_byte = CHAR_TO_BYTE (iend);
if (istart < GPT && GPT < iend)
move_gap_both (iend, iend_byte);
if (! NILP (base_url))
{
CHECK_STRING (base_url);
burl = SSDATA (base_url);
}
buftext = BYTE_POS_ADDR (istart_byte);
#ifdef REL_ALLOC
/* Prevent ralloc.c from relocating the current buffer while libxml2
functions below read its text. */
r_alloc_inhibit_buffer_relocation (1);
#endif
if (htmlp)
doc = htmlReadMemory ((char *)buftext,
iend_byte - istart_byte, burl, "utf-8",
HTML_PARSE_RECOVER|HTML_PARSE_NONET|
HTML_PARSE_NOWARNING|HTML_PARSE_NOERROR|
HTML_PARSE_NOBLANKS);
else
doc = xmlReadMemory ((char *)buftext,
iend_byte - istart_byte, burl, "utf-8",
XML_PARSE_NONET|XML_PARSE_NOWARNING|
XML_PARSE_NOBLANKS |XML_PARSE_NOERROR);
#ifdef REL_ALLOC
r_alloc_inhibit_buffer_relocation (0);
#endif
/* If the assertion below fails, malloc was called inside the above
libxml2 functions, and ralloc.c caused relocation of buffer text,
so we could have read from unrelated memory. */
eassert (buftext == BYTE_POS_ADDR (istart_byte));
if (doc != NULL)
{
Lisp_Object r = Qnil;
if (NILP(discard_comments))
{
/* If the document has toplevel comments, then this should
get us the nodes and the comments. */
xmlNode *n = doc->children;
while (n) {
if (!NILP (r))
result = Fcons (r, result);
r = make_dom (n);
n = n->next;
}
}
if (NILP (result)) {
/* The document doesn't have toplevel comments or we discarded
them. Get the tree the proper way. */
xmlNode *node = xmlDocGetRootElement (doc);
if (node != NULL)
result = make_dom (node);
} else
result = Fcons (Qtop, Fcons (Qnil, Fnreverse (Fcons (r, result))));
xmlFreeDoc (doc);
}
return result;
}
/* This compares two directory listings in case of a `write' event for
a directory. Generate resulting file notification events. The old
directory listing is retrieved from watch_object, it will be
replaced by the new directory listing at the end of this
function. */
static void
kqueue_compare_dir_list (Lisp_Object watch_object)
{
Lisp_Object dir, pending_dl, deleted_dl;
Lisp_Object old_directory_files, old_dl, new_directory_files, new_dl, dl;
dir = XCAR (XCDR (watch_object));
pending_dl = Qnil;
deleted_dl = Qnil;
old_directory_files = Fnth (make_number (4), watch_object);
old_dl = kqueue_directory_listing (old_directory_files);
/* When the directory is not accessible anymore, it has been deleted. */
if (NILP (Ffile_directory_p (dir))) {
kqueue_generate_event (watch_object, Fcons (Qdelete, Qnil), dir, Qnil);
return;
}
new_directory_files =
directory_files_internal (dir, Qnil, Qnil, Qnil, 1, Qnil);
new_dl = kqueue_directory_listing (new_directory_files);
/* Parse through the old list. */
dl = old_dl;
while (1) {
Lisp_Object old_entry, new_entry, dl1;
if (NILP (dl))
break;
/* Search for an entry with the same inode. */
old_entry = XCAR (dl);
new_entry = assq_no_quit (XCAR (old_entry), new_dl);
if (! NILP (Fequal (old_entry, new_entry))) {
/* Both entries are identical. Nothing to do. */
new_dl = Fdelq (new_entry, new_dl);
goto the_end;
}
/* Both entries have the same inode. */
if (! NILP (new_entry)) {
/* Both entries have the same file name. */
if (strcmp (SSDATA (XCAR (XCDR (old_entry))),
SSDATA (XCAR (XCDR (new_entry)))) == 0) {
/* Modification time has been changed, the file has been written. */
if (NILP (Fequal (Fnth (make_number (2), old_entry),
Fnth (make_number (2), new_entry))))
kqueue_generate_event
(watch_object, Fcons (Qwrite, Qnil), XCAR (XCDR (old_entry)), Qnil);
/* Status change time has been changed, the file attributes
have changed. */
if (NILP (Fequal (Fnth (make_number (3), old_entry),
Fnth (make_number (3), new_entry))))
kqueue_generate_event
(watch_object, Fcons (Qattrib, Qnil),
XCAR (XCDR (old_entry)), Qnil);
} else {
/* The file has been renamed. */
kqueue_generate_event
(watch_object, Fcons (Qrename, Qnil),
XCAR (XCDR (old_entry)), XCAR (XCDR (new_entry)));
deleted_dl = Fcons (new_entry, deleted_dl);
}
new_dl = Fdelq (new_entry, new_dl);
goto the_end;
}
/* Search, whether there is a file with the same name but another
inode. */
for (dl1 = new_dl; ! NILP (dl1); dl1 = XCDR (dl1)) {
new_entry = XCAR (dl1);
if (strcmp (SSDATA (XCAR (XCDR (old_entry))),
SSDATA (XCAR (XCDR (new_entry)))) == 0) {
pending_dl = Fcons (new_entry, pending_dl);
new_dl = Fdelq (new_entry, new_dl);
goto the_end;
}
}
/* Check, whether this a pending file. */
new_entry = assq_no_quit (XCAR (old_entry), pending_dl);
if (NILP (new_entry)) {
/* Check, whether this is an already deleted file (by rename). */
for (dl1 = deleted_dl; ! NILP (dl1); dl1 = XCDR (dl1)) {
new_entry = XCAR (dl1);
if (strcmp (SSDATA (XCAR (XCDR (old_entry))),
SSDATA (XCAR (XCDR (new_entry)))) == 0) {
deleted_dl = Fdelq (new_entry, deleted_dl);
goto the_end;
}
}
/* The file has been deleted. */
kqueue_generate_event
(watch_object, Fcons (Qdelete, Qnil), XCAR (XCDR (old_entry)), Qnil);
} else {
/* The file has been renamed. */
kqueue_generate_event
(watch_object, Fcons (Qrename, Qnil),
XCAR (XCDR (old_entry)), XCAR (XCDR (new_entry)));
pending_dl = Fdelq (new_entry, pending_dl);
}
the_end:
dl = XCDR (dl);
old_dl = Fdelq (old_entry, old_dl);
}
/* Parse through the resulting new list. */
dl = new_dl;
while (1) {
Lisp_Object entry;
if (NILP (dl))
break;
/* A new file has appeared. */
entry = XCAR (dl);
kqueue_generate_event
(watch_object, Fcons (Qcreate, Qnil), XCAR (XCDR (entry)), Qnil);
/* Check size of that file. */
Lisp_Object size = Fnth (make_number (4), entry);
if (FLOATP (size) || (XINT (size) > 0))
kqueue_generate_event
(watch_object, Fcons (Qwrite, Qnil), XCAR (XCDR (entry)), Qnil);
dl = XCDR (dl);
new_dl = Fdelq (entry, new_dl);
}
/* Parse through the resulting pending_dl list. */
dl = pending_dl;
while (1) {
Lisp_Object entry;
if (NILP (dl))
break;
/* A file is still pending. Assume it was a write. */
entry = XCAR (dl);
kqueue_generate_event
(watch_object, Fcons (Qwrite, Qnil), XCAR (XCDR (entry)), Qnil);
dl = XCDR (dl);
pending_dl = Fdelq (entry, pending_dl);
}
/* At this point, old_dl, new_dl and pending_dl shall be empty.
deleted_dl might not be empty when there was a rename to a
nonexistent file. Let's make a check for this (might be removed
once the code is stable). */
if (! NILP (old_dl))
report_file_error ("Old list not empty", old_dl);
if (! NILP (new_dl))
report_file_error ("New list not empty", new_dl);
if (! NILP (pending_dl))
report_file_error ("Pending events list not empty", pending_dl);
// if (! NILP (deleted_dl))
// report_file_error ("Deleted events list not empty", deleted_dl);
/* Replace old directory listing with the new one. */
XSETCDR (Fnthcdr (make_number (3), watch_object),
Fcons (new_directory_files, Qnil));
return;
}
/* This is the callback function for arriving signals from
g_file_monitor. It shall create a Lisp event, and put it into
Emacs input queue. */
static gboolean
dir_monitor_callback (GFileMonitor *monitor,
GFile *file,
GFile *other_file,
GFileMonitorEvent event_type,
gpointer user_data)
{
Lisp_Object symbol, monitor_object, watch_object, flags;
char *name = g_file_get_parse_name (file);
char *oname = other_file ? g_file_get_parse_name (other_file) : NULL;
/* Determine event symbol. */
switch (event_type)
{
case G_FILE_MONITOR_EVENT_CHANGED:
symbol = Qchanged;
break;
case G_FILE_MONITOR_EVENT_CHANGES_DONE_HINT:
symbol = Qchanges_done_hint;
break;
case G_FILE_MONITOR_EVENT_DELETED:
symbol = Qdeleted;
break;
case G_FILE_MONITOR_EVENT_CREATED:
symbol = Qcreated;
break;
case G_FILE_MONITOR_EVENT_ATTRIBUTE_CHANGED:
symbol = Qattribute_changed;
break;
case G_FILE_MONITOR_EVENT_PRE_UNMOUNT:
symbol = Qpre_unmount;
break;
case G_FILE_MONITOR_EVENT_UNMOUNTED:
symbol = Qunmounted;
break;
case G_FILE_MONITOR_EVENT_MOVED:
symbol = Qmoved;
break;
default:
goto cleanup;
}
/* Determine callback function. */
monitor_object = make_pointer_integer (monitor);
eassert (INTEGERP (monitor_object));
watch_object = assq_no_quit (monitor_object, watch_list);
if (CONSP (watch_object))
{
struct input_event event;
Lisp_Object otail = oname ? list1 (build_string (oname)) : Qnil;
/* Check, whether event_type is expected. */
flags = XCAR (XCDR (XCDR (watch_object)));
if ((!NILP (Fmember (Qchange, flags)) &&
!NILP (Fmember (symbol, list5 (Qchanged, Qchanges_done_hint,
Qdeleted, Qcreated, Qmoved)))) ||
(!NILP (Fmember (Qattribute_change, flags)) &&
((EQ (symbol, Qattribute_changed)))))
{
/* Construct an event. */
EVENT_INIT (event);
event.kind = FILE_NOTIFY_EVENT;
event.frame_or_window = Qnil;
event.arg = list2 (Fcons (monitor_object,
Fcons (symbol,
Fcons (build_string (name),
otail))),
XCAR (XCDR (XCDR (XCDR (watch_object)))));
/* Store it into the input event queue. */
kbd_buffer_store_event (&event);
/* XD_DEBUG_MESSAGE ("%s", XD_OBJECT_TO_STRING (event.arg)); */
}
/* Cancel monitor if file or directory is deleted. */
if (!NILP (Fmember (symbol, list2 (Qdeleted, Qmoved))) &&
(strcmp (name, SSDATA (XCAR (XCDR (watch_object)))) == 0) &&
!g_file_monitor_is_cancelled (monitor))
g_file_monitor_cancel (monitor);
}
/* Cleanup. */
cleanup:
g_free (name);
g_free (oname);
return TRUE;
}
static Lisp_Object
parse_region (Lisp_Object start, Lisp_Object end, Lisp_Object base_url, int htmlp)
{
xmlDoc *doc;
Lisp_Object result = Qnil;
const char *burl = "";
EMACS_INT bytes;
EMACS_INT istart, iend;
LIBXML_TEST_VERSION;
validate_region (&start, &end);
istart = XINT (start);
iend = XINT (end);
if (istart < GPT && GPT < iend)
move_gap (iend);
if (! NILP (base_url))
{
CHECK_STRING (base_url);
burl = SSDATA (base_url);
}
bytes = CHAR_TO_BYTE (iend) - CHAR_TO_BYTE (istart);
if (htmlp)
doc = htmlReadMemory ((char *) BYTE_POS_ADDR (CHAR_TO_BYTE (istart)),
bytes, burl, "utf-8",
HTML_PARSE_RECOVER|HTML_PARSE_NONET|
HTML_PARSE_NOWARNING|HTML_PARSE_NOERROR|
HTML_PARSE_NOBLANKS);
else
doc = xmlReadMemory ((char *) BYTE_POS_ADDR (CHAR_TO_BYTE (istart)),
bytes, burl, "utf-8",
XML_PARSE_NONET|XML_PARSE_NOWARNING|
XML_PARSE_NOBLANKS |XML_PARSE_NOERROR);
if (doc != NULL)
{
xmlNode *n = doc->children->next;
Lisp_Object r = Qnil;
while (n) {
if (!NILP (r))
result = Fcons (r, result);
r = make_dom (n);
n = n->next;
}
if (NILP (result))
result = r;
else
result = Fcons (intern ("top"),
Fcons (Qnil, Fnreverse (Fcons (r, result))));
xmlFreeDoc (doc);
xmlCleanupParser ();
}
return result;
}
static Lisp_Object
w32_dialog_show (struct frame *f, Lisp_Object title,
Lisp_Object header, char **error)
{
int i, nb_buttons = 0;
char dialog_name[6];
int menu_item_selection;
widget_value *wv, *first_wv = 0, *prev_wv = 0;
/* Number of elements seen so far, before boundary. */
int left_count = 0;
/* true means we've seen the boundary between left-hand elts and
right-hand. */
bool boundary_seen = false;
*error = NULL;
if (menu_items_n_panes > 1)
{
*error = "Multiple panes in dialog box";
return Qnil;
}
/* Create a tree of widget_value objects
representing the text label and buttons. */
{
Lisp_Object pane_name;
char *pane_string;
pane_name = AREF (menu_items, MENU_ITEMS_PANE_NAME);
pane_string = (NILP (pane_name)
? "" : SSDATA (pane_name));
prev_wv = make_widget_value ("message", pane_string, true, Qnil);
first_wv = prev_wv;
/* Loop over all panes and items, filling in the tree. */
i = MENU_ITEMS_PANE_LENGTH;
while (i < menu_items_used)
{
/* Create a new item within current pane. */
Lisp_Object item_name, enable, descrip, help;
item_name = AREF (menu_items, i + MENU_ITEMS_ITEM_NAME);
enable = AREF (menu_items, i + MENU_ITEMS_ITEM_ENABLE);
descrip = AREF (menu_items, i + MENU_ITEMS_ITEM_EQUIV_KEY);
help = AREF (menu_items, i + MENU_ITEMS_ITEM_HELP);
if (NILP (item_name))
{
free_menubar_widget_value_tree (first_wv);
*error = "Submenu in dialog items";
return Qnil;
}
if (EQ (item_name, Qquote))
{
/* This is the boundary between left-side elts
and right-side elts. Stop incrementing right_count. */
boundary_seen = true;
i++;
continue;
}
if (nb_buttons >= 9)
{
free_menubar_widget_value_tree (first_wv);
*error = "Too many dialog items";
return Qnil;
}
wv = make_widget_value (button_names[nb_buttons],
SSDATA (item_name),
!NILP (enable), Qnil);
prev_wv->next = wv;
if (!NILP (descrip))
wv->key = SSDATA (descrip);
wv->call_data = aref_addr (menu_items, i);
prev_wv = wv;
if (! boundary_seen)
left_count++;
nb_buttons++;
i += MENU_ITEMS_ITEM_LENGTH;
}
/* If the boundary was not specified,
by default put half on the left and half on the right. */
if (! boundary_seen)
left_count = nb_buttons - nb_buttons / 2;
wv = make_widget_value (dialog_name, NULL, false, Qnil);
/* Frame title: 'Q' = Question, 'I' = Information.
Can also have 'E' = Error if, one day, we want
a popup for errors. */
if (NILP (header))
dialog_name[0] = 'Q';
else
dialog_name[0] = 'I';
/* Dialog boxes use a really stupid name encoding
which specifies how many buttons to use
and how many buttons are on the right. */
dialog_name[1] = '0' + nb_buttons;
dialog_name[2] = 'B';
dialog_name[3] = 'R';
/* Number of buttons to put on the right. */
dialog_name[4] = '0' + nb_buttons - left_count;
dialog_name[5] = 0;
wv->contents = first_wv;
first_wv = wv;
}
/* Actually create the dialog. */
dialog_id = widget_id_tick++;
menu = lw_create_widget (first_wv->name, "dialog", dialog_id, first_wv,
f->output_data.w32->widget, true, 0,
dialog_selection_callback, 0);
lw_modify_all_widgets (dialog_id, first_wv->contents, TRUE);
/* Free the widget_value objects we used to specify the contents. */
free_menubar_widget_value_tree (first_wv);
/* No selection has been chosen yet. */
menu_item_selection = 0;
/* Display the menu. */
lw_pop_up_all_widgets (dialog_id);
/* Process events that apply to the menu. */
popup_get_selection ((XEvent *) 0, FRAME_DISPLAY_INFO (f), dialog_id);
lw_destroy_all_widgets (dialog_id);
/* Find the selected item, and its pane, to return
the proper value. */
if (menu_item_selection != 0)
{
i = 0;
while (i < menu_items_used)
{
Lisp_Object entry;
if (EQ (AREF (menu_items, i), Qt))
i += MENU_ITEMS_PANE_LENGTH;
else
{
entry = AREF (menu_items, i + MENU_ITEMS_ITEM_VALUE);
if (menu_item_selection == i)
return entry;
i += MENU_ITEMS_ITEM_LENGTH;
}
}
}
else
/* Make "Cancel" equivalent to C-g. */
Fsignal (Qquit, Qnil);
return Qnil;
}
Lisp_Object
get_doc_string (Lisp_Object filepos, int unibyte, int definition)
{
char *from, *to;
register int fd;
register char *name;
register char *p, *p1;
EMACS_INT minsize;
EMACS_INT offset, position;
Lisp_Object file, tem;
if (INTEGERP (filepos))
{
file = Vdoc_file_name;
position = XINT (filepos);
}
else if (CONSP (filepos))
{
file = XCAR (filepos);
position = XINT (XCDR (filepos));
}
else
return Qnil;
if (position < 0)
position = - position;
if (!STRINGP (Vdoc_directory))
return Qnil;
if (!STRINGP (file))
return Qnil;
/* Put the file name in NAME as a C string.
If it is relative, combine it with Vdoc_directory. */
tem = Ffile_name_absolute_p (file);
if (NILP (tem))
{
minsize = SCHARS (Vdoc_directory);
/* sizeof ("../etc/") == 8 */
if (minsize < 8)
minsize = 8;
name = (char *) alloca (minsize + SCHARS (file) + 8);
strcpy (name, SSDATA (Vdoc_directory));
strcat (name, SSDATA (file));
}
else
{
name = SSDATA (file);
}
fd = emacs_open (name, O_RDONLY, 0);
if (fd < 0)
{
#ifndef CANNOT_DUMP
if (!NILP (Vpurify_flag))
{
/* Preparing to dump; DOC file is probably not installed.
So check in ../etc. */
strcpy (name, "../etc/");
strcat (name, SSDATA (file));
fd = emacs_open (name, O_RDONLY, 0);
}
#endif
if (fd < 0)
error ("Cannot open doc string file \"%s\"", name);
}
/* Seek only to beginning of disk block. */
/* Make sure we read at least 1024 bytes before `position'
so we can check the leading text for consistency. */
offset = min (position, max (1024, position % (8 * 1024)));
if (0 > lseek (fd, position - offset, 0))
{
emacs_close (fd);
error ("Position %"pI"d out of range in doc string file \"%s\"",
position, name);
}
/* Read the doc string into get_doc_string_buffer.
P points beyond the data just read. */
p = get_doc_string_buffer;
while (1)
{
EMACS_INT space_left = (get_doc_string_buffer_size
- (p - get_doc_string_buffer));
int nread;
/* Allocate or grow the buffer if we need to. */
if (space_left == 0)
{
EMACS_INT in_buffer = p - get_doc_string_buffer;
get_doc_string_buffer_size += 16 * 1024;
get_doc_string_buffer
= (char *) xrealloc (get_doc_string_buffer,
get_doc_string_buffer_size + 1);
p = get_doc_string_buffer + in_buffer;
space_left = (get_doc_string_buffer_size
- (p - get_doc_string_buffer));
}
/* Read a disk block at a time.
If we read the same block last time, maybe skip this? */
if (space_left > 1024 * 8)
space_left = 1024 * 8;
nread = emacs_read (fd, p, space_left);
if (nread < 0)
{
emacs_close (fd);
error ("Read error on documentation file");
}
p[nread] = 0;
if (!nread)
break;
if (p == get_doc_string_buffer)
p1 = strchr (p + offset, '\037');
else
p1 = strchr (p, '\037');
if (p1)
{
*p1 = 0;
p = p1;
break;
}
p += nread;
}
emacs_close (fd);
/* Sanity checking. */
if (CONSP (filepos))
{
int test = 1;
if (get_doc_string_buffer[offset - test++] != ' ')
return Qnil;
while (get_doc_string_buffer[offset - test] >= '0'
&& get_doc_string_buffer[offset - test] <= '9')
test++;
if (get_doc_string_buffer[offset - test++] != '@'
|| get_doc_string_buffer[offset - test] != '#')
return Qnil;
}
else
{
int test = 1;
if (get_doc_string_buffer[offset - test++] != '\n')
return Qnil;
while (get_doc_string_buffer[offset - test] > ' ')
test++;
if (get_doc_string_buffer[offset - test] != '\037')
return Qnil;
}
/* Scan the text and perform quoting with ^A (char code 1).
^A^A becomes ^A, ^A0 becomes a null char, and ^A_ becomes a ^_. */
from = get_doc_string_buffer + offset;
to = get_doc_string_buffer + offset;
while (from != p)
{
if (*from == 1)
{
int c;
from++;
c = *from++;
if (c == 1)
*to++ = c;
else if (c == '0')
*to++ = 0;
else if (c == '_')
*to++ = 037;
else
{
unsigned char uc = c;
error ("\
Invalid data in documentation file -- %c followed by code %03o",
1, uc);
}
}
else
*to++ = *from++;
}
/* If DEFINITION, read from this buffer
the same way we would read bytes from a file. */
if (definition)
{
read_bytecode_pointer = (unsigned char *) get_doc_string_buffer + offset;
return Fread (Qlambda);
}
if (unibyte)
return make_unibyte_string (get_doc_string_buffer + offset,
to - (get_doc_string_buffer + offset));
else
{
/* The data determines whether the string is multibyte. */
EMACS_INT nchars =
multibyte_chars_in_text (((unsigned char *) get_doc_string_buffer
+ offset),
to - (get_doc_string_buffer + offset));
return make_string_from_bytes (get_doc_string_buffer + offset,
nchars,
to - (get_doc_string_buffer + offset));
}
}
void
x_session_initialize (struct x_display_info *dpyinfo)
{
#define SM_ERRORSTRING_LEN 512
char errorstring[SM_ERRORSTRING_LEN];
char *previous_id = NULL;
SmcCallbacks callbacks;
ptrdiff_t name_len = 0;
ice_fd = -1;
doing_interact = false;
/* Check if we where started by the session manager. If so, we will
have a previous id. */
if (STRINGP (Vx_session_previous_id))
previous_id = SSDATA (Vx_session_previous_id);
/* Construct the path to the Emacs program. */
if (STRINGP (Vinvocation_directory))
name_len += SBYTES (Vinvocation_directory);
if (STRINGP (Vinvocation_name))
name_len += SBYTES (Vinvocation_name);
/* This malloc will not be freed, but it is only done once, and hopefully
not very large */
emacs_program = xmalloc (name_len + 1);
char *z = emacs_program;
if (STRINGP (Vinvocation_directory))
z = lispstpcpy (z, Vinvocation_directory);
if (STRINGP (Vinvocation_name))
lispstpcpy (z, Vinvocation_name);
/* The SM protocol says all callbacks are mandatory, so set up all
here and in the mask passed to SmcOpenConnection. */
callbacks.save_yourself.callback = smc_save_yourself_CB;
callbacks.save_yourself.client_data = 0;
callbacks.die.callback = smc_die_CB;
callbacks.die.client_data = 0;
callbacks.save_complete.callback = smc_save_complete_CB;
callbacks.save_complete.client_data = 0;
callbacks.shutdown_cancelled.callback = smc_shutdown_cancelled_CB;
callbacks.shutdown_cancelled.client_data = 0;
/* Set error handlers. */
SmcSetErrorHandler (smc_error_handler);
IceSetErrorHandler (ice_error_handler);
IceSetIOErrorHandler (ice_io_error_handler);
/* Install callback for when connection status changes. */
IceAddConnectionWatch (ice_conn_watch_CB, 0);
/* Open the connection to the session manager. A failure is not
critical, it usually means that no session manager is running.
The errorstring is here for debugging. */
smc_conn = SmcOpenConnection (NULL, NULL, 1, 0,
(SmcSaveYourselfProcMask|
SmcDieProcMask|
SmcSaveCompleteProcMask|
SmcShutdownCancelledProcMask),
&callbacks,
previous_id,
&client_id,
SM_ERRORSTRING_LEN,
errorstring);
if (smc_conn != 0)
{
Vx_session_id = build_string (client_id);
#ifdef USE_GTK
/* GTK creates a leader window by itself, but we need to tell
it about our client_id. */
gdk_x11_set_sm_client_id (client_id);
#else
create_client_leader_window (dpyinfo, client_id);
#endif
}
}
Lisp_Object
directory_files_internal (Lisp_Object directory, Lisp_Object full,
Lisp_Object match, Lisp_Object nosort, bool attrs,
Lisp_Object id_format)
{
ptrdiff_t directory_nbytes;
Lisp_Object list, dirfilename, encoded_directory;
struct re_pattern_buffer *bufp = NULL;
bool needsep = 0;
ptrdiff_t count = SPECPDL_INDEX ();
#ifdef WINDOWSNT
Lisp_Object w32_save = Qnil;
#endif
/* Don't let the compiler optimize away all copies of DIRECTORY,
which would break GC; see Bug#16986. */
Lisp_Object volatile directory_volatile = directory;
/* Because of file name handlers, these functions might call
Ffuncall, and cause a GC. */
list = encoded_directory = dirfilename = Qnil;
dirfilename = Fdirectory_file_name (directory);
if (!NILP (match))
{
CHECK_STRING (match);
/* MATCH might be a flawed regular expression. Rather than
catching and signaling our own errors, we just call
compile_pattern to do the work for us. */
/* Pass 1 for the MULTIBYTE arg
because we do make multibyte strings if the contents warrant. */
# ifdef WINDOWSNT
/* Windows users want case-insensitive wildcards. */
bufp = compile_pattern (match, 0,
BVAR (&buffer_defaults, case_canon_table), 0, 1);
# else /* !WINDOWSNT */
bufp = compile_pattern (match, 0, Qnil, 0, 1);
# endif /* !WINDOWSNT */
}
/* Note: ENCODE_FILE and DECODE_FILE can GC because they can run
run_pre_post_conversion_on_str which calls Lisp directly and
indirectly. */
dirfilename = ENCODE_FILE (dirfilename);
encoded_directory = ENCODE_FILE (directory);
/* Now *bufp is the compiled form of MATCH; don't call anything
which might compile a new regexp until we're done with the loop! */
int fd;
DIR *d = open_directory (dirfilename, &fd);
/* Unfortunately, we can now invoke expand-file-name and
file-attributes on filenames, both of which can throw, so we must
do a proper unwind-protect. */
record_unwind_protect_ptr (directory_files_internal_unwind, d);
#ifdef WINDOWSNT
if (attrs)
{
/* Do this only once to avoid doing it (in w32.c:stat) for each
file in the directory, when we call Ffile_attributes below. */
record_unwind_protect (directory_files_internal_w32_unwind,
Vw32_get_true_file_attributes);
w32_save = Vw32_get_true_file_attributes;
if (EQ (Vw32_get_true_file_attributes, Qlocal))
{
/* w32.c:stat will notice these bindings and avoid calling
GetDriveType for each file. */
if (is_slow_fs (SSDATA (dirfilename)))
Vw32_get_true_file_attributes = Qnil;
else
Vw32_get_true_file_attributes = Qt;
}
}
#endif
directory_nbytes = SBYTES (directory);
re_match_object = Qt;
/* Decide whether we need to add a directory separator. */
if (directory_nbytes == 0
|| !IS_ANY_SEP (SREF (directory, directory_nbytes - 1)))
needsep = 1;
/* Loop reading directory entries. */
for (struct dirent *dp; (dp = read_dirent (d, directory)); )
{
ptrdiff_t len = dirent_namelen (dp);
Lisp_Object name = make_unibyte_string (dp->d_name, len);
Lisp_Object finalname = name;
/* Note: DECODE_FILE can GC; it should protect its argument,
though. */
name = DECODE_FILE (name);
len = SBYTES (name);
/* Now that we have unwind_protect in place, we might as well
allow matching to be interrupted. */
immediate_quit = 1;
QUIT;
bool wanted = (NILP (match)
|| re_search (bufp, SSDATA (name), len, 0, len, 0) >= 0);
immediate_quit = 0;
if (wanted)
{
if (!NILP (full))
{
Lisp_Object fullname;
ptrdiff_t nbytes = len + directory_nbytes + needsep;
ptrdiff_t nchars;
fullname = make_uninit_multibyte_string (nbytes, nbytes);
memcpy (SDATA (fullname), SDATA (directory),
directory_nbytes);
if (needsep)
SSET (fullname, directory_nbytes, DIRECTORY_SEP);
memcpy (SDATA (fullname) + directory_nbytes + needsep,
SDATA (name), len);
nchars = multibyte_chars_in_text (SDATA (fullname), nbytes);
/* Some bug somewhere. */
if (nchars > nbytes)
emacs_abort ();
STRING_SET_CHARS (fullname, nchars);
if (nchars == nbytes)
STRING_SET_UNIBYTE (fullname);
finalname = fullname;
}
else
finalname = name;
if (attrs)
{
Lisp_Object fileattrs
= file_attributes (fd, dp->d_name, id_format);
list = Fcons (Fcons (finalname, fileattrs), list);
}
else
list = Fcons (finalname, list);
}
}
closedir (d);
#ifdef WINDOWSNT
if (attrs)
Vw32_get_true_file_attributes = w32_save;
#endif
/* Discard the unwind protect. */
specpdl_ptr = specpdl + count;
if (NILP (nosort))
list = Fsort (Fnreverse (list),
attrs ? Qfile_attributes_lessp : Qstring_lessp);
(void) directory_volatile;
return list;
}
widget_value *
digest_single_submenu (int start, int end, bool top_level_items)
{
widget_value *wv, *prev_wv, *save_wv, *first_wv;
int i;
int submenu_depth = 0;
widget_value **submenu_stack;
bool panes_seen = 0;
struct frame *f = XFRAME (Vmenu_updating_frame);
USE_SAFE_ALLOCA;
SAFE_NALLOCA (submenu_stack, 1, menu_items_used);
wv = make_widget_value ("menu", NULL, true, Qnil);
wv->button_type = BUTTON_TYPE_NONE;
first_wv = wv;
save_wv = 0;
prev_wv = 0;
/* Loop over all panes and items made by the preceding call
to parse_single_submenu and construct a tree of widget_value objects.
Ignore the panes and items used by previous calls to
digest_single_submenu, even though those are also in menu_items. */
i = start;
while (i < end)
{
if (EQ (AREF (menu_items, i), Qnil))
{
submenu_stack[submenu_depth++] = save_wv;
save_wv = prev_wv;
prev_wv = 0;
i++;
}
else if (EQ (AREF (menu_items, i), Qlambda))
{
prev_wv = save_wv;
save_wv = submenu_stack[--submenu_depth];
i++;
}
else if (EQ (AREF (menu_items, i), Qt)
&& submenu_depth != 0)
i += MENU_ITEMS_PANE_LENGTH;
/* Ignore a nil in the item list.
It's meaningful only for dialog boxes. */
else if (EQ (AREF (menu_items, i), Qquote))
i += 1;
else if (EQ (AREF (menu_items, i), Qt))
{
/* Create a new pane. */
Lisp_Object pane_name;
const char *pane_string;
panes_seen = 1;
pane_name = AREF (menu_items, i + MENU_ITEMS_PANE_NAME);
/* TTY menus display menu items via tty_write_glyphs, which
will encode the strings as appropriate. */
if (!FRAME_TERMCAP_P (f))
{
#ifdef HAVE_NTGUI
if (STRINGP (pane_name))
{
if (unicode_append_menu)
/* Encode as UTF-8 for now. */
pane_name = ENCODE_UTF_8 (pane_name);
else if (STRING_MULTIBYTE (pane_name))
pane_name = ENCODE_SYSTEM (pane_name);
ASET (menu_items, i + MENU_ITEMS_PANE_NAME, pane_name);
}
#elif defined (USE_LUCID) && defined (HAVE_XFT)
if (STRINGP (pane_name))
{
pane_name = ENCODE_UTF_8 (pane_name);
ASET (menu_items, i + MENU_ITEMS_PANE_NAME, pane_name);
}
#elif !defined (HAVE_MULTILINGUAL_MENU)
if (STRINGP (pane_name) && STRING_MULTIBYTE (pane_name))
{
pane_name = ENCODE_MENU_STRING (pane_name);
ASET (menu_items, i + MENU_ITEMS_PANE_NAME, pane_name);
}
#endif
}
pane_string = (NILP (pane_name)
? "" : SSDATA (pane_name));
/* If there is just one top-level pane, put all its items directly
under the top-level menu. */
if (menu_items_n_panes == 1)
pane_string = "";
/* If the pane has a meaningful name,
make the pane a top-level menu item
with its items as a submenu beneath it. */
if (strcmp (pane_string, ""))
{
/* Set value to 1 so update_submenu_strings can handle '@'. */
wv = make_widget_value (NULL, (char *) 1, true, Qnil);
if (save_wv)
save_wv->next = wv;
else
first_wv->contents = wv;
wv->lname = pane_name;
wv->button_type = BUTTON_TYPE_NONE;
save_wv = wv;
}
else
save_wv = first_wv;
prev_wv = 0;
i += MENU_ITEMS_PANE_LENGTH;
}
else
{
/* Create a new item within current pane. */
Lisp_Object item_name, enable, descrip, def, type, selected;
Lisp_Object help;
/* All items should be contained in panes. */
if (! panes_seen)
emacs_abort ();
item_name = AREF (menu_items, i + MENU_ITEMS_ITEM_NAME);
enable = AREF (menu_items, i + MENU_ITEMS_ITEM_ENABLE);
descrip = AREF (menu_items, i + MENU_ITEMS_ITEM_EQUIV_KEY);
def = AREF (menu_items, i + MENU_ITEMS_ITEM_DEFINITION);
type = AREF (menu_items, i + MENU_ITEMS_ITEM_TYPE);
selected = AREF (menu_items, i + MENU_ITEMS_ITEM_SELECTED);
help = AREF (menu_items, i + MENU_ITEMS_ITEM_HELP);
/* TTY menu items and their descriptions will be encoded by
tty_write_glyphs. */
if (!FRAME_TERMCAP_P (f))
{
#ifdef HAVE_NTGUI
if (STRINGP (item_name))
{
if (unicode_append_menu)
item_name = ENCODE_UTF_8 (item_name);
else if (STRING_MULTIBYTE (item_name))
item_name = ENCODE_SYSTEM (item_name);
ASET (menu_items, i + MENU_ITEMS_ITEM_NAME, item_name);
}
if (STRINGP (descrip) && STRING_MULTIBYTE (descrip))
{
descrip = ENCODE_SYSTEM (descrip);
ASET (menu_items, i + MENU_ITEMS_ITEM_EQUIV_KEY, descrip);
}
#elif USE_LUCID
if (STRINGP (item_name))
{
item_name = ENCODE_UTF_8 (item_name);
ASET (menu_items, i + MENU_ITEMS_ITEM_NAME, item_name);
}
if (STRINGP (descrip))
{
descrip = ENCODE_UTF_8 (descrip);
ASET (menu_items, i + MENU_ITEMS_ITEM_EQUIV_KEY, descrip);
}
#elif !defined (HAVE_MULTILINGUAL_MENU)
if (STRING_MULTIBYTE (item_name))
{
item_name = ENCODE_MENU_STRING (item_name);
ASET (menu_items, i + MENU_ITEMS_ITEM_NAME, item_name);
}
if (STRINGP (descrip) && STRING_MULTIBYTE (descrip))
{
descrip = ENCODE_MENU_STRING (descrip);
ASET (menu_items, i + MENU_ITEMS_ITEM_EQUIV_KEY, descrip);
}
#endif
}
wv = make_widget_value (NULL, NULL, !NILP (enable),
STRINGP (help) ? help : Qnil);
if (prev_wv)
prev_wv->next = wv;
else
save_wv->contents = wv;
wv->lname = item_name;
if (!NILP (descrip))
wv->lkey = descrip;
/* The intptr_t cast avoids a warning. There's no problem
as long as pointers have enough bits to hold small integers. */
wv->call_data = (!NILP (def) ? (void *) (intptr_t) i : 0);
if (NILP (type))
wv->button_type = BUTTON_TYPE_NONE;
else if (EQ (type, QCradio))
wv->button_type = BUTTON_TYPE_RADIO;
else if (EQ (type, QCtoggle))
wv->button_type = BUTTON_TYPE_TOGGLE;
else
emacs_abort ();
wv->selected = !NILP (selected);
prev_wv = wv;
i += MENU_ITEMS_ITEM_LENGTH;
}
}
/* If we have just one "menu item"
that was originally a button, return it by itself. */
if (top_level_items && first_wv->contents && first_wv->contents->next == 0)
{
wv = first_wv;
first_wv = first_wv->contents;
xfree (wv);
}
SAFE_FREE ();
return first_wv;
}
static char const *
string_default (Lisp_Object s, char const *default_value)
{
return STRINGP (s) ? SSDATA (s) : default_value;
}
return ASIZE (lvec);
}
/* Subroutines. */
DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0,
doc: /* Load module FILE. */)
(Lisp_Object file)
{
dynlib_handle_ptr handle;
emacs_init_function module_init;
void *gpl_sym;
CHECK_STRING (file);
handle = dynlib_open (SSDATA (file));
if (!handle)
error ("Cannot load file %s: %s", SDATA (file), dynlib_error ());
gpl_sym = dynlib_sym (handle, "plugin_is_GPL_compatible");
if (!gpl_sym)
error ("Module %s is not GPL compatible", SDATA (file));
module_init = (emacs_init_function) dynlib_func (handle, "emacs_module_init");
if (!module_init)
error ("Module %s does not have an init function.", SDATA (file));
struct emacs_runtime_private rt; /* Includes the public emacs_env. */
struct emacs_env_private priv;
initialize_environment (&rt.pub, &priv);
struct emacs_runtime pub =
static void
delete_temp_file (Lisp_Object name)
{
unlink (SSDATA (name));
}
static void
smc_save_yourself_CB (SmcConn smcConn,
SmPointer clientData,
int saveType,
Bool shutdown,
int interactStyle,
Bool fast)
{
#define NR_PROPS 5
SmProp *props[NR_PROPS];
SmProp prop_ptr[NR_PROPS];
SmPropValue values[20];
int val_idx = 0;
int props_idx = 0;
char *cwd = NULL;
char *smid_opt, *chdir_opt = NULL;
/* How to start a new instance of Emacs. */
props[props_idx] = &prop_ptr[props_idx];
props[props_idx]->name = SmCloneCommand;
props[props_idx]->type = SmLISTofARRAY8;
props[props_idx]->num_vals = 1;
props[props_idx]->vals = &values[val_idx++];
props[props_idx]->vals[0].length = strlen (emacs_program);
props[props_idx]->vals[0].value = emacs_program;
++props_idx;
/* The name of the program. */
props[props_idx] = &prop_ptr[props_idx];
props[props_idx]->name = SmProgram;
props[props_idx]->type = SmARRAY8;
props[props_idx]->num_vals = 1;
props[props_idx]->vals = &values[val_idx++];
props[props_idx]->vals[0].length = strlen (SSDATA (Vinvocation_name));
props[props_idx]->vals[0].value = SDATA (Vinvocation_name);
++props_idx;
/* How to restart Emacs. */
props[props_idx] = &prop_ptr[props_idx];
props[props_idx]->name = SmRestartCommand;
props[props_idx]->type = SmLISTofARRAY8;
/* /path/to/emacs, --smid=xxx --no-splash --chdir=dir */
props[props_idx]->num_vals = 4;
props[props_idx]->vals = &values[val_idx];
props[props_idx]->vals[0].length = strlen (emacs_program);
props[props_idx]->vals[0].value = emacs_program;
smid_opt = xmalloc (strlen (SMID_OPT) + strlen (client_id) + 1);
strcpy (smid_opt, SMID_OPT);
strcat (smid_opt, client_id);
props[props_idx]->vals[1].length = strlen (smid_opt);
props[props_idx]->vals[1].value = smid_opt;
props[props_idx]->vals[2].length = strlen (NOSPLASH_OPT);
props[props_idx]->vals[2].value = NOSPLASH_OPT;
cwd = get_current_dir_name ();
if (cwd)
{
chdir_opt = xmalloc (strlen (CHDIR_OPT) + strlen (cwd) + 1);
strcpy (chdir_opt, CHDIR_OPT);
strcat (chdir_opt, cwd);
props[props_idx]->vals[3].length = strlen (chdir_opt);
props[props_idx]->vals[3].value = chdir_opt;
}
val_idx += cwd ? 4 : 3;
++props_idx;
/* User id. */
props[props_idx] = &prop_ptr[props_idx];
props[props_idx]->name = SmUserID;
props[props_idx]->type = SmARRAY8;
props[props_idx]->num_vals = 1;
props[props_idx]->vals = &values[val_idx++];
props[props_idx]->vals[0].length = strlen (SSDATA (Vuser_login_name));
props[props_idx]->vals[0].value = SDATA (Vuser_login_name);
++props_idx;
if (cwd)
{
props[props_idx] = &prop_ptr[props_idx];
props[props_idx]->name = SmCurrentDirectory;
props[props_idx]->type = SmARRAY8;
props[props_idx]->num_vals = 1;
props[props_idx]->vals = &values[val_idx++];
props[props_idx]->vals[0].length = strlen (cwd);
props[props_idx]->vals[0].value = cwd;
++props_idx;
}
SmcSetProperties (smcConn, props_idx, props);
xfree (smid_opt);
xfree (chdir_opt);
free (cwd);
/* See if we maybe shall interact with the user. */
if (interactStyle != SmInteractStyleAny
|| ! shutdown
|| saveType == SmSaveLocal
|| ! SmcInteractRequest (smcConn, SmDialogNormal, smc_interact_CB, 0))
{
/* No interaction, we are done saving ourself. */
SmcSaveYourselfDone (smcConn, True);
}
}
static int
current_lock_owner (lock_info_type *owner, char *lfname)
{
int len, ret;
int local_owner = 0;
char *at, *dot, *colon;
char *lfinfo = 0;
int bufsize = 50;
/* Read arbitrarily-long contents of symlink. Similar code in
file-symlink-p in fileio.c. */
do
{
bufsize *= 2;
lfinfo = (char *) xrealloc (lfinfo, bufsize);
errno = 0;
len = readlink (lfname, lfinfo, bufsize);
#ifdef ERANGE
/* HP-UX reports ERANGE if the buffer is too small. */
if (len == -1 && errno == ERANGE)
len = bufsize;
#endif
}
while (len >= bufsize);
/* If nonexistent lock file, all is well; otherwise, got strange error. */
if (len == -1)
{
xfree (lfinfo);
return errno == ENOENT ? 0 : -1;
}
/* Link info exists, so `len' is its length. Null terminate. */
lfinfo[len] = 0;
/* Even if the caller doesn't want the owner info, we still have to
read it to determine return value, so allocate it. */
if (!owner)
{
owner = (lock_info_type *) alloca (sizeof (lock_info_type));
local_owner = 1;
}
/* Parse [email protected]:BOOT_TIME. If can't parse, return -1. */
/* The USER is everything before the last @. */
at = strrchr (lfinfo, '@');
dot = strrchr (lfinfo, '.');
if (!at || !dot)
{
xfree (lfinfo);
return -1;
}
len = at - lfinfo;
owner->user = (char *) xmalloc (len + 1);
strncpy (owner->user, lfinfo, len);
owner->user[len] = 0;
/* The PID is everything from the last `.' to the `:'. */
owner->pid = atoi (dot + 1);
colon = dot;
while (*colon && *colon != ':')
colon++;
/* After the `:', if there is one, comes the boot time. */
if (*colon == ':')
owner->boot_time = atoi (colon + 1);
else
owner->boot_time = 0;
/* The host is everything in between. */
len = dot - at - 1;
owner->host = (char *) xmalloc (len + 1);
strncpy (owner->host, at + 1, len);
owner->host[len] = 0;
/* We're done looking at the link info. */
xfree (lfinfo);
/* On current host? */
if (STRINGP (Fsystem_name ())
&& strcmp (owner->host, SSDATA (Fsystem_name ())) == 0)
{
if (owner->pid == getpid ())
ret = 2; /* We own it. */
else if (owner->pid > 0
&& (kill (owner->pid, 0) >= 0 || errno == EPERM)
&& (owner->boot_time == 0
|| within_one_second (owner->boot_time, get_boot_time ())))
ret = 1; /* An existing process on this machine owns it. */
/* The owner process is dead or has a strange pid (<=0), so try to
zap the lockfile. */
else if (unlink (lfname) < 0)
ret = -1;
else
ret = 0;
}
else
{ /* If we wanted to support the check for stale locks on remote machines,
here's where we'd do it. */
ret = 1;
}
/* Avoid garbage. */
if (local_owner || ret <= 0)
{
FREE_LOCK_INFO (*owner);
}
return ret;
}