static Lisp_Object
conv_filename_to_w32_unicode (Lisp_Object in, int absolute_p)
{
ssize_t converted_len;
Lisp_Object converted;
unsigned flags;
int count = SPECPDL_INDEX ();
chdir_to_default_directory ();
flags = CCP_POSIX_TO_WIN_W;
if (!absolute_p) {
flags |= CCP_RELATIVE;
}
in = ENCODE_FILE (in);
converted_len = cygwin_conv_path (flags, SDATA (in), NULL, 0);
if (converted_len < 2)
error ("cygwin_conv_path: %s", strerror (errno));
converted = make_uninit_string (converted_len - 1);
if (cygwin_conv_path (flags, SDATA (in),
SDATA (converted), converted_len))
error ("cygwin_conv_path: %s", strerror (errno));
return unbind_to (count, converted);
}
static Lisp_Object
conv_filename_from_w32_unicode (const wchar_t* in, int absolute_p)
{
ssize_t converted_len;
Lisp_Object converted;
unsigned flags;
int count = SPECPDL_INDEX ();
chdir_to_default_directory ();
flags = CCP_WIN_W_TO_POSIX;
if (!absolute_p) {
flags |= CCP_RELATIVE;
}
converted_len = cygwin_conv_path (flags, in, NULL, 0);
if (converted_len < 1)
error ("cygwin_conv_path: %s", strerror (errno));
converted = make_uninit_string (converted_len - 1 /*subtract terminator*/);
if (cygwin_conv_path (flags, in, SDATA (converted), converted_len))
error ("cygwin_conv_path: %s", strerror (errno));
return unbind_to (count, DECODE_FILE (converted));
}
static Lisp_Object
x_get_local_selection (Lisp_Object selection_symbol, Lisp_Object target_type,
int local_request, struct mac_display_info *dpyinfo)
{
Lisp_Object local_value;
Lisp_Object handler_fn, value, type, check;
if (!x_selection_owner_p (selection_symbol, dpyinfo))
return Qnil;
local_value = LOCAL_SELECTION (selection_symbol, dpyinfo);
/* TIMESTAMP is a special case. */
if (EQ (target_type, QTIMESTAMP))
{
handler_fn = Qnil;
value = XCAR (XCDR (XCDR (local_value)));
}
else
{
/* Don't allow a quit within the converter.
When the user types C-g, he would be surprised
if by luck it came during a converter. */
ptrdiff_t count = SPECPDL_INDEX ();
specbind (Qinhibit_quit, Qt);
CHECK_SYMBOL (target_type);
handler_fn = Fcdr (Fassq (target_type, Vselection_converter_alist));
/* gcpro is not needed here since nothing but HANDLER_FN
is live, and that ought to be a symbol. */
if (!NILP (handler_fn))
value = call3 (handler_fn,
selection_symbol, (local_request ? Qnil : target_type),
XCAR (XCDR (local_value)));
else
value = Qnil;
unbind_to (count, Qnil);
}
if (local_request)
return value;
/* Make sure this value is of a type that we could transmit
to another application. */
type = target_type;
check = value;
if (CONSP (value)
&& SYMBOLP (XCAR (value)))
type = XCAR (value),
check = XCDR (value);
if (NILP (value) || mac_valid_selection_value_p (check, type))
return value;
signal_error ("Invalid data returned by selection-conversion function",
list2 (handler_fn, value));
}
static Lisp_Object
call_process_cleanup (Lisp_Object arg)
{
Lisp_Object fdpid = Fcdr (arg);
int fd;
#if defined (MSDOS)
Lisp_Object file;
#else
pid_t pid;
#endif
Fset_buffer (Fcar (arg));
CONS_TO_INTEGER (Fcar (fdpid), int, fd);
#if defined (MSDOS)
/* for MSDOS fdpid is really (fd . tempfile) */
file = Fcdr (fdpid);
/* FD is -1 and FILE is "" when we didn't actually create a
temporary file in call-process. */
if (fd >= 0)
emacs_close (fd);
if (!(strcmp (SDATA (file), NULL_DEVICE) == 0 || SREF (file, 0) == '\0'))
unlink (SDATA (file));
#else /* not MSDOS */
CONS_TO_INTEGER (Fcdr (fdpid), pid_t, pid);
if (call_process_exited)
{
emacs_close (fd);
return Qnil;
}
if (EMACS_KILLPG (pid, SIGINT) == 0)
{
ptrdiff_t count = SPECPDL_INDEX ();
record_unwind_protect (call_process_kill, fdpid);
message1 ("Waiting for process to die...(type C-g again to kill it instantly)");
immediate_quit = 1;
QUIT;
wait_for_termination (pid);
immediate_quit = 0;
specpdl_ptr = specpdl + count; /* Discard the unwind protect. */
message1 ("Waiting for process to die...done");
}
synch_process_alive = 0;
emacs_close (fd);
#endif /* not MSDOS */
return Qnil;
}
static Lisp_Object
call_process_cleanup (Lisp_Object arg)
{
Lisp_Object fdpid = Fcdr (arg);
#if defined (MSDOS)
Lisp_Object file;
#else
int pid;
#endif
Fset_buffer (Fcar (arg));
#if defined (MSDOS)
/* for MSDOS fdpid is really (fd . tempfile) */
file = Fcdr (fdpid);
emacs_close (XFASTINT (Fcar (fdpid)));
if (strcmp (SDATA (file), NULL_DEVICE) != 0)
unlink (SDATA (file));
#else /* not MSDOS */
pid = XFASTINT (Fcdr (fdpid));
if (call_process_exited)
{
emacs_close (XFASTINT (Fcar (fdpid)));
return Qnil;
}
if (EMACS_KILLPG (pid, SIGINT) == 0)
{
int count = SPECPDL_INDEX ();
record_unwind_protect (call_process_kill, fdpid);
message1 ("Waiting for process to die...(type C-g again to kill it instantly)");
immediate_quit = 1;
QUIT;
wait_for_termination (pid);
immediate_quit = 0;
specpdl_ptr = specpdl + count; /* Discard the unwind protect. */
message1 ("Waiting for process to die...done");
}
synch_process_alive = 0;
emacs_close (XFASTINT (Fcar (fdpid)));
#endif /* not MSDOS */
return Qnil;
}
}
return i_result;
}
/* END: Windows specific functions */
#endif /* WINDOWSNT */
DEFUN ("play-sound-internal", Fplay_sound_internal, Splay_sound_internal, 1, 1, 0,
doc: /* Play sound SOUND.
Internal use only, use `play-sound' instead. */)
(Lisp_Object sound)
{
Lisp_Object attrs[SOUND_ATTR_SENTINEL];
int count = SPECPDL_INDEX ();
#ifndef WINDOWSNT
Lisp_Object file;
struct gcpro gcpro1, gcpro2;
Lisp_Object args[2];
#else /* WINDOWSNT */
int len = 0;
Lisp_Object lo_file = {0};
char * psz_file = NULL;
unsigned long ui_volume_tmp = UINT_MAX;
unsigned long ui_volume = UINT_MAX;
int i_result = 0;
#endif /* WINDOWSNT */
/* Parse the sound specification. Give up if it is invalid. */
Lisp_Object
get_doc_string (Lisp_Object filepos, bool unibyte, bool definition)
{
char *from, *to, *name, *p, *p1;
int fd;
int offset;
EMACS_INT position;
Lisp_Object file, tem, pos;
ptrdiff_t count;
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);
Lisp_Object docdir
= NILP (tem) ? ENCODE_FILE (Vdoc_directory) : empty_unibyte_string;
ptrdiff_t docdir_sizemax = SBYTES (docdir) + 1;
#ifndef CANNOT_DUMP
docdir_sizemax = max (docdir_sizemax, sizeof sibling_etc);
#endif
name = SAFE_ALLOCA (docdir_sizemax + SBYTES (file));
lispstpcpy (lispstpcpy (name, docdir), 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. */
lispstpcpy (stpcpy (name, sibling_etc), file);
fd = emacs_open (name, O_RDONLY, 0);
}
#endif
if (fd < 0)
{
if (errno == EMFILE || errno == ENFILE)
report_file_error ("Read error on documentation file", file);
SAFE_FREE ();
AUTO_STRING (cannot_open, "Cannot open doc string file \"");
AUTO_STRING (quote_nl, "\"\n");
return concat3 (cannot_open, file, quote_nl);
}
}
count = SPECPDL_INDEX ();
record_unwind_protect_int (close_file_unwind, fd);
/* 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)
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)
{
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)
report_file_error ("Read error on documentation file", 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;
}
unbind_to (count, Qnil);
SAFE_FREE ();
/* 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));
}
}
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 ();
}
If DESTINATION is 0, `call-process' returns immediately with value nil.
Otherwise it waits for PROGRAM to terminate
and returns a numeric exit status or a signal description string.
If you quit, the process is killed with SIGINT, or SIGKILL if you quit again.
The process runs in `default-directory' if that is local (as
determined by `unhandled-file-name-directory'), or "~" otherwise. If
you want to run a process in a remote directory use `process-file'.
usage: (call-process PROGRAM &optional INFILE DESTINATION DISPLAY &rest ARGS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
Lisp_Object infile, encoded_infile;
int filefd;
ptrdiff_t count = SPECPDL_INDEX ();
if (nargs >= 2 && ! NILP (args[1]))
{
infile = Fexpand_file_name (args[1], BVAR (current_buffer, directory));
CHECK_STRING (infile);
}
else
infile = build_string (NULL_DEVICE);
encoded_infile = ENCODE_FILE (infile);
filefd = emacs_open (SSDATA (encoded_infile), O_RDONLY, 0);
if (filefd < 0)
report_file_error ("Opening process input file", infile);
record_unwind_protect_int (close_file_unwind, filefd);
keyboard input, then this normally results in a quit and
`x-popup-menu' does not return. But if POSITION is a mouse button
event (indicating that the user invoked the menu with the mouse) then
no quit occurs and `x-popup-menu' returns nil. */)
(Lisp_Object position, Lisp_Object menu)
{
Lisp_Object keymap, tem;
int xpos = 0, ypos = 0;
Lisp_Object title;
const char *error_name = NULL;
Lisp_Object selection = Qnil;
FRAME_PTR f = NULL;
Lisp_Object x, y, window;
int keymaps = 0;
int for_click = 0;
int specpdl_count = SPECPDL_INDEX ();
struct gcpro gcpro1;
if (NILP (position))
/* This is an obsolete call, which wants us to precompute the
keybinding equivalents, but we don't do that any more anyway. */
return Qnil;
#ifdef HAVE_MENUS
{
int get_current_pos_p = 0;
/* FIXME!! check_w32 (); or check_x (); or check_ns (); */
/* Decode the first argument: find the window and the coordinates. */
if (EQ (position, Qt)
|| (CONSP (position) && (EQ (XCAR (position), Qmenu_bar)
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 void
x_own_selection (Lisp_Object selection_name, Lisp_Object selection_value,
Lisp_Object frame)
{
struct frame *f = XFRAME (frame);
struct mac_display_info *dpyinfo = FRAME_MAC_DISPLAY_INFO (f);
Time timestamp = last_event_timestamp;
OSStatus err;
Selection sel;
struct gcpro gcpro1, gcpro2;
Lisp_Object rest, handler_fn, value, target_type;
GCPRO2 (selection_name, selection_value);
block_input ();
err = mac_get_selection_from_symbol (selection_name, 1, &sel);
if (err == noErr && sel)
{
/* Don't allow a quit within the converter.
When the user types C-g, he would be surprised
if by luck it came during a converter. */
ptrdiff_t count = SPECPDL_INDEX ();
specbind (Qinhibit_quit, Qt);
for (rest = Vselection_converter_alist; CONSP (rest); rest = XCDR (rest))
{
if (!(CONSP (XCAR (rest))
&& (target_type = XCAR (XCAR (rest)),
SYMBOLP (target_type))
&& mac_valid_selection_target_p (target_type)
&& (handler_fn = XCDR (XCAR (rest)),
SYMBOLP (handler_fn))))
continue;
if (!NILP (handler_fn))
value = call3 (handler_fn, selection_name,
target_type, selection_value);
else
value = Qnil;
if (NILP (value))
continue;
if (mac_valid_selection_value_p (value, target_type))
err = mac_put_selection_value (sel, target_type, value);
else if (CONSP (value)
&& EQ (XCAR (value), target_type)
&& mac_valid_selection_value_p (XCDR (value), target_type))
err = mac_put_selection_value (sel, target_type, XCDR (value));
}
unbind_to (count, Qnil);
}
unblock_input ();
UNGCPRO;
if (sel && err != noErr)
error ("Can't set selection");
/* Now update the local cache */
{
Lisp_Object selection_data;
Lisp_Object ownership_info;
Lisp_Object prev_value;
if (sel)
{
block_input ();
ownership_info = mac_get_selection_ownership_info (sel);
unblock_input ();
}
else
ownership_info = Qnil; /* dummy value for local-only selection */
selection_data = list5 (selection_name, selection_value,
INTEGER_TO_CONS (timestamp), frame, ownership_info);
prev_value = LOCAL_SELECTION (selection_name, dpyinfo);
tset_selection_alist
(dpyinfo->terminal,
Fcons (selection_data, dpyinfo->terminal->Vselection_alist));
/* If we already owned the selection, remove the old selection
data. Don't use Fdelq as that may QUIT. */
if (!NILP (prev_value))
{
/* We know it's not the CAR, so it's easy. */
Lisp_Object rest = dpyinfo->terminal->Vselection_alist;
for (; CONSP (rest); rest = XCDR (rest))
if (EQ (prev_value, Fcar (XCDR (rest))))
{
XSETCDR (rest, XCDR (XCDR (rest)));
break;
}
}
}
}
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,
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 (SDATA (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, SDATA (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);
}
keyboard input, then this normally results in a quit and
`x-popup-menu' does not return. But if POSITION is a mouse button
event (indicating that the user invoked the menu with the mouse) then
no quit occurs and `x-popup-menu' returns nil. */)
(Lisp_Object position, Lisp_Object menu)
{
Lisp_Object keymap, tem;
int xpos = 0, ypos = 0;
Lisp_Object title;
const char *error_name = NULL;
Lisp_Object selection = Qnil;
struct frame *f = NULL;
Lisp_Object x, y, window;
bool keymaps = 0;
bool for_click = 0;
ptrdiff_t specpdl_count = SPECPDL_INDEX ();
struct gcpro gcpro1;
if (NILP (position))
/* This is an obsolete call, which wants us to precompute the
keybinding equivalents, but we don't do that any more anyway. */
return Qnil;
#ifdef HAVE_MENUS
{
bool get_current_pos_p = 0;
check_window_system (SELECTED_FRAME ());
/* Decode the first argument: find the window and the coordinates. */
if (EQ (position, Qt)
struct gcpro gcpro1;
GCPRO1 (default_filename);
RETURN_UNGCPRO (CALLN (Ffuncall, intern ("read-file-name"),
callint_message, Qnil, default_filename,
mustmatch, initial, predicate));
}
/* BEWARE: Calling this directly from C would defeat the purpose! */
DEFUN ("funcall-interactively", Ffuncall_interactively, Sfuncall_interactively,
1, MANY, 0, doc: /* Like `funcall' but marks the call as interactive.
I.e. arrange that within the called function `called-interactively-p' will
return non-nil.
usage: (funcall-interactively FUNCTION &rest ARGUMENTS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
ptrdiff_t speccount = SPECPDL_INDEX ();
temporarily_switch_to_single_kboard (NULL);
/* Nothing special to do here, all the work is inside
`called-interactively-p'. Which will look for us as a marker in the
backtrace. */
return unbind_to (speccount, Ffuncall (nargs, args));
}
DEFUN ("call-interactively", Fcall_interactively, Scall_interactively, 1, 3, 0,
doc: /* Call FUNCTION, providing args according to its interactive calling specs.
Return the value FUNCTION returns.
The function contains a specification of how to do the argument reading.
In the case of user-defined functions, this is specified by placing a call
to the function `interactive' at the top level of the function body.
See `interactive'.
Lisp_Object
directory_files_internal (Lisp_Object directory, Lisp_Object full,
Lisp_Object match, Lisp_Object nosort, bool attrs,
Lisp_Object id_format)
{
DIR *d;
int fd;
ptrdiff_t directory_nbytes;
Lisp_Object list, dirfilename, encoded_directory;
struct re_pattern_buffer *bufp = NULL;
bool needsep = 0;
ptrdiff_t count = SPECPDL_INDEX ();
struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
struct dirent *dp;
#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. Although this is required
only in the common case where GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS,
it shouldn't break anything in the other cases. */
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;
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! */
d = open_directory (SSDATA (dirfilename), &fd);
if (d == NULL)
report_file_error ("Opening directory", directory);
/* 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)
{
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 (;;)
{
ptrdiff_t len;
bool wanted = 0;
Lisp_Object name, finalname;
struct gcpro gcpro1, gcpro2;
errno = 0;
dp = readdir (d);
if (!dp)
{
if (errno == EAGAIN || errno == EINTR)
{
QUIT;
continue;
}
break;
}
len = dirent_namelen (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)
|| re_search (bufp, SSDATA (name), len, 0, len, 0) >= 0)
wanted = 1;
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);
}
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);
(void) directory_volatile;
RETURN_UNGCPRO (list);
}
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;
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);
/* 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);
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 file_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;
/* Windows users want case-insensitive wildcards. */
Lisp_Object case_table =
#ifdef WINDOWSNT
BVAR (&buffer_defaults, case_canon_table)
#else
Qnil
#endif
;
if (!NILP (match))
CHECK_STRING (match);
/* 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. */
maybe_quit ();
bool wanted = (NILP (match) ||
fast_string_match_internal (
match, name, case_table) >= 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, directory, 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;
}
