static u16 global_add(struct global_state *gstate,
struct string *name, value val)
{
struct symbol *pos;
ivalue old_size, aindex;
GCCHECK(val);
GCPRO2(gstate, name);
old_size = vector_len(gstate->environment->values);
aindex = env_add_entry(gstate->environment, val);
if (vector_len(gstate->environment->values) != old_size) /* Increase mvars too */
{
struct vector *new_mvars = alloc_vector(vector_len(gstate->environment->values));
memcpy(new_mvars->data, gstate->mvars->data,
gstate->mvars->o.size - sizeof(struct obj));
gstate->mvars = new_mvars;
}
GCPOP(2);
gstate->mvars->data[aindex] = makeint(var_normal);
pos = table_add_fast(gstate->global, name, makeint(aindex));
SET_READONLY(pos); /* index of global vars never changes */
return aindex;
}
static Lisp_Object
gtk_canonicalize_console_connection (Lisp_Object connection, Error_behavior errb)
{
Lisp_Object hostname = Qnil;
struct gcpro gcpro1, gcpro2;
GCPRO2 (connection, hostname);
connection = build_string ("gtk");
RETURN_UNGCPRO (connection);
}
struct symbol *alloc_symbol(struct string *name, value data)
{
struct symbol *newp;
GCCHECK(name);
GCCHECK(data);
GCPRO2(name, data);
newp = (struct symbol *)unsafe_allocate_record(type_symbol, 2);
GCPOP(2);
newp->name = name;
newp->data = data;
return newp;
}
struct list *alloc_list(value car, value cdr)
{
struct list *newp;
GCCHECK(car);
GCCHECK(cdr);
GCPRO2(car, cdr);
newp = (struct list *)unsafe_allocate_record(type_pair, 2);
GCPOP(2);
newp->car = car;
newp->cdr = cdr;
return newp;
}
u16 mglobal_lookup(struct global_state *gstate, struct string *name)
/* Returns: the index for global variable name in environment.
If name doesn't exist yet, it is created with a variable
whose value is NULL.
*/
{
struct symbol *pos;
struct string *tname;
if (table_lookup(gstate->global, name->str, &pos))
return (u16)intval(pos->data);
GCPRO2(gstate, name);
tname = alloc_string_n(string_len(name));
strcpy(tname->str, name->str);
GCPOP(2);
return global_add(gstate, tname, NULL);
}
static void write_code(struct oport *f, struct code *c)
{
u16 nbins, i;
GCPRO2(f, c);
nbins = code_length(c);
if (c->varname)
{
write_string(f, prt_display, c->varname);
pputs(": ", f);
}
pprintf(f, "Code[");
write_string(f, prt_display, c->filename);
pprintf(f, ":%u] %u bytes:\n", c->lineno, nbins);
i = 0;
while (i < nbins)
i += write_instruction(f, c->ins + i, i);
pprintf(f, "\n%u locals, %u stack\n",
c->nb_locals, c->stkdepth);
GCPOP(2);
}
static void
single_menu_item (Lisp_Object key, Lisp_Object item, Lisp_Object dummy, void *skp_v)
{
Lisp_Object map, item_string, enabled;
struct gcpro gcpro1, gcpro2;
bool res;
struct skp *skp = skp_v;
/* Parse the menu item and leave the result in item_properties. */
GCPRO2 (key, item);
res = parse_menu_item (item, 0);
UNGCPRO;
if (!res)
return; /* Not a menu item. */
map = AREF (item_properties, ITEM_PROPERTY_MAP);
enabled = AREF (item_properties, ITEM_PROPERTY_ENABLE);
item_string = AREF (item_properties, ITEM_PROPERTY_NAME);
if (!NILP (map) && SREF (item_string, 0) == '@')
{
if (!NILP (enabled))
/* An enabled separate pane. Remember this to handle it later. */
skp->pending_maps = Fcons (Fcons (map, Fcons (item_string, key)),
skp->pending_maps);
return;
}
/* Simulate radio buttons and toggle boxes by putting a prefix in
front of them. */
if (!have_boxes ())
{
char const *prefix = 0;
Lisp_Object type = AREF (item_properties, ITEM_PROPERTY_TYPE);
if (!NILP (type))
{
Lisp_Object selected
= AREF (item_properties, ITEM_PROPERTY_SELECTED);
if (skp->notbuttons)
/* The first button. Line up previous items in this menu. */
{
int idx = skp->notbuttons; /* Index for first item this menu. */
int submenu = 0;
Lisp_Object tem;
while (idx < menu_items_used)
{
tem
= AREF (menu_items, idx + MENU_ITEMS_ITEM_NAME);
if (NILP (tem))
{
idx++;
submenu++; /* Skip sub menu. */
}
else if (EQ (tem, Qlambda))
{
idx++;
submenu--; /* End sub menu. */
}
else if (EQ (tem, Qt))
idx += 3; /* Skip new pane marker. */
else if (EQ (tem, Qquote))
idx++; /* Skip a left, right divider. */
else
{
if (!submenu && SREF (tem, 0) != '\0'
&& SREF (tem, 0) != '-')
ASET (menu_items, idx + MENU_ITEMS_ITEM_NAME,
concat2 (SCOPED_STRING (" "), tem));
idx += MENU_ITEMS_ITEM_LENGTH;
}
}
skp->notbuttons = 0;
}
/* Calculate prefix, if any, for this item. */
if (EQ (type, QCtoggle))
prefix = NILP (selected) ? "[ ] " : "[X] ";
else if (EQ (type, QCradio))
prefix = NILP (selected) ? "( ) " : "(*) ";
}
/* Not a button. If we have earlier buttons, then we need a prefix. */
else if (!skp->notbuttons && SREF (item_string, 0) != '\0'
&& SREF (item_string, 0) != '-')
prefix = " ";
if (prefix)
item_string = concat2 (SCOPED_STRING (prefix), item_string);
}
if ((FRAME_TERMCAP_P (XFRAME (Vmenu_updating_frame))
|| FRAME_MSDOS_P (XFRAME (Vmenu_updating_frame)))
&& !NILP (map))
/* Indicate visually that this is a submenu. */
item_string = concat2 (item_string, SCOPED_STRING (" >"));
push_menu_item (item_string, enabled, key,
AREF (item_properties, ITEM_PROPERTY_DEF),
AREF (item_properties, ITEM_PROPERTY_KEYEQ),
AREF (item_properties, ITEM_PROPERTY_TYPE),
AREF (item_properties, ITEM_PROPERTY_SELECTED),
AREF (item_properties, ITEM_PROPERTY_HELP));
#if defined (USE_X_TOOLKIT) || defined (USE_GTK) || defined (HAVE_NS) || defined (HAVE_NTGUI)
/* Display a submenu using the toolkit. */
if (FRAME_WINDOW_P (XFRAME (Vmenu_updating_frame))
&& ! (NILP (map) || NILP (enabled)))
{
push_submenu_start ();
single_keymap_panes (map, Qnil, key, skp->maxdepth - 1);
push_submenu_end ();
}
#endif
}
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);
}
static void
single_menu_item (Lisp_Object key, Lisp_Object item, Lisp_Object dummy, void *skp_v)
{
Lisp_Object map, item_string, enabled;
struct gcpro gcpro1, gcpro2;
int res;
struct skp *skp = skp_v;
/* Parse the menu item and leave the result in item_properties. */
GCPRO2 (key, item);
res = parse_menu_item (item, 0);
UNGCPRO;
if (!res)
return; /* Not a menu item. */
map = XVECTOR (item_properties)->contents[ITEM_PROPERTY_MAP];
enabled = XVECTOR (item_properties)->contents[ITEM_PROPERTY_ENABLE];
item_string = XVECTOR (item_properties)->contents[ITEM_PROPERTY_NAME];
if (!NILP (map) && SREF (item_string, 0) == '@')
{
if (!NILP (enabled))
/* An enabled separate pane. Remember this to handle it later. */
skp->pending_maps = Fcons (Fcons (map, Fcons (item_string, key)),
skp->pending_maps);
return;
}
#if defined(HAVE_X_WINDOWS) || defined(MSDOS)
#ifndef HAVE_BOXES
/* Simulate radio buttons and toggle boxes by putting a prefix in
front of them. */
{
Lisp_Object prefix = Qnil;
Lisp_Object type = XVECTOR (item_properties)->contents[ITEM_PROPERTY_TYPE];
if (!NILP (type))
{
Lisp_Object selected
= XVECTOR (item_properties)->contents[ITEM_PROPERTY_SELECTED];
if (skp->notbuttons)
/* The first button. Line up previous items in this menu. */
{
int index = skp->notbuttons; /* Index for first item this menu. */
int submenu = 0;
Lisp_Object tem;
while (index < menu_items_used)
{
tem
= XVECTOR (menu_items)->contents[index + MENU_ITEMS_ITEM_NAME];
if (NILP (tem))
{
index++;
submenu++; /* Skip sub menu. */
}
else if (EQ (tem, Qlambda))
{
index++;
submenu--; /* End sub menu. */
}
else if (EQ (tem, Qt))
index += 3; /* Skip new pane marker. */
else if (EQ (tem, Qquote))
index++; /* Skip a left, right divider. */
else
{
if (!submenu && SREF (tem, 0) != '\0'
&& SREF (tem, 0) != '-')
XVECTOR (menu_items)->contents[index + MENU_ITEMS_ITEM_NAME]
= concat2 (build_string (" "), tem);
index += MENU_ITEMS_ITEM_LENGTH;
}
}
skp->notbuttons = 0;
}
/* Calculate prefix, if any, for this item. */
if (EQ (type, QCtoggle))
prefix = build_string (NILP (selected) ? "[ ] " : "[X] ");
else if (EQ (type, QCradio))
prefix = build_string (NILP (selected) ? "( ) " : "(*) ");
}
/* Not a button. If we have earlier buttons, then we need a prefix. */
else if (!skp->notbuttons && SREF (item_string, 0) != '\0'
&& SREF (item_string, 0) != '-')
prefix = build_string (" ");
if (!NILP (prefix))
item_string = concat2 (prefix, item_string);
}
#endif /* not HAVE_BOXES */
#if ! defined (USE_X_TOOLKIT) && ! defined (USE_GTK)
if (!NILP (map))
/* Indicate visually that this is a submenu. */
item_string = concat2 (item_string, build_string (" >"));
#endif
#endif /* HAVE_X_WINDOWS || MSDOS */
push_menu_item (item_string, enabled, key,
XVECTOR (item_properties)->contents[ITEM_PROPERTY_DEF],
XVECTOR (item_properties)->contents[ITEM_PROPERTY_KEYEQ],
XVECTOR (item_properties)->contents[ITEM_PROPERTY_TYPE],
XVECTOR (item_properties)->contents[ITEM_PROPERTY_SELECTED],
XVECTOR (item_properties)->contents[ITEM_PROPERTY_HELP]);
#if defined (USE_X_TOOLKIT) || defined (USE_GTK) || defined (HAVE_NS) || defined (HAVE_NTGUI)
/* Display a submenu using the toolkit. */
if (! (NILP (map) || NILP (enabled)))
{
push_submenu_start ();
single_keymap_panes (map, Qnil, key, skp->maxdepth - 1);
push_submenu_end ();
}
#endif
}
static Lisp_Object
extract_object_file_name (int fd, EMACS_INT doc_pos,
Ibyte *name_nonreloc, Lisp_Object name_reloc,
int standard_doc_file)
{
Ibyte buf[DOC_MAX_FILENAME_LENGTH+1];
Ibyte *buffer = buf;
int buffer_size = sizeof (buf) - 1, space_left;
Ibyte *from, *to;
REGISTER Ibyte *p = buffer;
Lisp_Object return_me;
Lisp_Object fdstream = Qnil, instream = Qnil;
struct gcpro gcpro1, gcpro2;
EMACS_INT position, seenS = 0;
GCPRO2 (fdstream, instream);
position = doc_pos > buffer_size ?
doc_pos - buffer_size : 0;
if (0 > lseek (fd, position, 0))
{
if (name_nonreloc)
name_reloc = build_istring (name_nonreloc);
return_me = list3 (build_msg_string
("Position out of range in doc string file"),
name_reloc, make_fixnum (position));
goto done;
}
fdstream = make_filedesc_input_stream (fd, 0, -1, 0, NULL);
Lstream_set_buffering (XLSTREAM (fdstream), LSTREAM_UNBUFFERED, 0);
instream =
make_coding_input_stream
(XLSTREAM (fdstream), standard_doc_file ? Qescape_quoted : Qbinary,
CODING_DECODE, 0);
Lstream_set_buffering (XLSTREAM (instream), LSTREAM_UNBUFFERED, 0);
space_left = buffer_size - (p - buffer);
while (space_left > 0)
{
int nread;
nread = Lstream_read (XLSTREAM (instream), p, space_left);
if (nread < 0)
{
return_me = list1 (build_msg_string
("Read error on documentation file"));
goto done;
}
p[nread] = 0;
if (!nread)
break;
p += nread;
space_left = buffer_size - (p - buffer);
}
/* First, search backward for the "\037S" that marks the beginning of the
file name, then search forward from that to the newline or to the end
of the buffer. */
from = p;
while (from > buf)
{
--from;
if (seenS)
{
if ('\037' == *from)
{
/* Got a file name; adjust `from' to point to it, break out of
the loop. */
from += 2;
break;
}
}
/* Is *from 'S' ? */
seenS = ('S' == *from);
}
if (buf == from)
{
/* We've scanned back to the beginning of the buffer without hitting
the file name. Either the file name plus the symbol name is longer
than DOC_MAX_FILENAME_LENGTH--which shouldn't happen, because it'll
trigger an assertion failure in make-docfile, the DOC file is
corrupt, or it was produced by a version of make-docfile that
doesn't store the file name with the symbol name and docstring. */
return_me = list1 (build_msg_string
("Object file name not stored in doc file"));
goto done;
}
to = from;
/* Search for the end of the file name. */
while (++to < p)
{
if ('\n' == *to || '\037' == *to)
{
break;
}
}
/* Don't require the file name to end in a newline. */
return_me = make_string (from, to - from);
done:
if (!NILP (instream))
{
Lstream_delete (XLSTREAM (instream));
Lstream_delete (XLSTREAM (fdstream));
}
UNGCPRO;
return return_me;
}
Lisp_Object
unparesseuxify_doc_string (int fd, EMACS_INT position,
Ibyte *name_nonreloc, Lisp_Object name_reloc,
int standard_doc_file)
{
Ibyte buf[512 * 32 + 1];
Ibyte *buffer = buf;
int buffer_size = sizeof (buf) - 1;
Ibyte *from, *to;
REGISTER Ibyte *p = buffer;
Lisp_Object return_me;
Lisp_Object fdstream = Qnil, instream = Qnil;
struct gcpro gcpro1, gcpro2;
GCPRO2 (fdstream, instream);
if (0 > lseek (fd, position, 0))
{
if (name_nonreloc)
name_reloc = build_istring (name_nonreloc);
return_me = list3 (build_msg_string
("Position out of range in doc string file"),
name_reloc, make_fixnum (position));
goto done;
}
fdstream = make_filedesc_input_stream (fd, 0, -1, 0, NULL);
Lstream_set_buffering (XLSTREAM (fdstream), LSTREAM_UNBUFFERED, 0);
instream =
make_coding_input_stream
/* Major trouble if we are too clever when reading byte-code
instructions!
#### We should have a way of handling escape-quoted elc files
(i.e. files with non-ASCII/Latin-1 chars in them). Currently this
is "solved" in bytecomp.el by never inserting lazy references in
such files. */
(XLSTREAM (fdstream), standard_doc_file ? Qescape_quoted : Qbinary,
CODING_DECODE, 0);
Lstream_set_buffering (XLSTREAM (instream), LSTREAM_UNBUFFERED, 0);
/* Read the doc string into a buffer.
Use the fixed buffer BUF if it is big enough; otherwise allocate one.
We store the buffer in use in BUFFER and its size in BUFFER_SIZE. */
while (1)
{
int space_left = buffer_size - (p - buffer);
int nread;
/* Switch to a bigger buffer if we need one. */
if (space_left == 0)
{
Ibyte *old_buffer = buffer;
buffer_size *= 2;
if (buffer == buf)
{
buffer = xnew_ibytes (buffer_size + 1);
memcpy (buffer, old_buffer, p - old_buffer);
}
else
XREALLOC_ARRAY (buffer, Ibyte, buffer_size + 1);
p += buffer - old_buffer;
space_left = buffer_size - (p - buffer);
}
/* Don't read too much at one go. */
if (space_left > 1024 * 8)
space_left = 1024 * 8;
nread = Lstream_read (XLSTREAM (instream), p, space_left);
if (nread < 0)
{
return_me = list1 (build_msg_string
("Read error on documentation file"));
goto done;
}
p[nread] = 0;
if (!nread)
break;
{
Ibyte *p1 = qxestrchr (p, '\037'); /* End of doc string marker */
if (p1)
{
*p1 = 0;
p = p1;
break;
}
}
p += nread;
}
/* Scan the text and remove quoting with ^A (char code 1).
^A^A becomes ^A, ^A0 becomes a null char, and ^A_ becomes a ^_. */
from = to = buffer;
while (from < p)
{
if (*from != 1 /*^A*/)
*to++ = *from++;
else
{
int c = *(++from);
from++;
switch (c)
{
case 1: *to++ = c; break;
case '0': *to++ = '\0'; break;
case '_': *to++ = '\037'; break;
default:
return_me = list2 (build_msg_string
("Invalid data in documentation file -- ^A followed by weird code"),
make_fixnum (c));
goto done;
}
}
}
return_me = make_string (buffer, to - buffer);
done:
if (!NILP (instream))
{
Lstream_delete (XLSTREAM (instream));
Lstream_delete (XLSTREAM (fdstream));
}
UNGCPRO;
if (buffer != buf) /* We must have allocated buffer above */
xfree (buffer);
return return_me;
}
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);
}
