static HGLOBAL
convert_to_handle_as_coded (Lisp_Object coding_system)
{
HGLOBAL htext;
unsigned char *dst = NULL;
struct coding_system coding;
ONTRACE (fprintf (stderr, "convert_to_handle_as_coded: %s\n",
SDATA (SYMBOL_NAME (coding_system))));
setup_windows_coding_system (coding_system, &coding);
coding.dst_bytes = SBYTES (current_text) * 2;
coding.destination = xmalloc (coding.dst_bytes);
encode_coding_object (&coding, current_text, 0, 0,
SCHARS (current_text), SBYTES (current_text), Qnil);
htext = GlobalAlloc (GMEM_MOVEABLE | GMEM_DDESHARE, coding.produced +2);
if (htext != NULL)
dst = (unsigned char *) GlobalLock (htext);
if (dst != NULL)
{
memcpy (dst, coding.destination, coding.produced);
/* Add the string terminator. Add two NULs in case we are
producing Unicode here. */
dst[coding.produced] = dst[coding.produced+1] = '\0';
GlobalUnlock (htext);
}
xfree (coding.destination);
return htext;
}
static void
fill_in_lock_file_name (register char *lockfile, register Lisp_Object fn)
{
ptrdiff_t length = SBYTES (fn);
register char *p;
struct stat st;
int count = 0;
strcpy (lockfile, SSDATA (fn));
/* Shift the nondirectory part of the file name (including the null)
right two characters. Here is one of the places where we'd have to
do something to support 14-character-max file names. */
for (p = lockfile + length; p != lockfile && *p != '/'; p--)
p[2] = *p;
/* Insert the `.#'. */
p[1] = '.';
p[2] = '#';
p = p + length + 2;
while (lstat (lockfile, &st) == 0 && !S_ISLNK (st.st_mode))
{
if (count > 9)
{
*p = '\0';
return;
}
sprintf (p, ".%d", count++);
}
}
static bool
module_copy_string_contents (emacs_env *env, emacs_value value, char *buffer,
ptrdiff_t *length)
{
MODULE_FUNCTION_BEGIN (false);
Lisp_Object lisp_str = value_to_lisp (value);
CHECK_STRING (lisp_str);
Lisp_Object lisp_str_utf8 = ENCODE_UTF_8 (lisp_str);
ptrdiff_t raw_size = SBYTES (lisp_str_utf8);
ptrdiff_t required_buf_size = raw_size + 1;
eassert (length != NULL);
if (buffer == NULL)
{
*length = required_buf_size;
return true;
}
eassert (*length >= 0);
if (*length < required_buf_size)
{
*length = required_buf_size;
xsignal0 (Qargs_out_of_range);
}
*length = required_buf_size;
memcpy (buffer, SDATA (lisp_str_utf8), raw_size + 1);
return true;
}
static void
check_string_without_embedded_nulls (Lisp_Object object)
{
CHECK_STRING (object);
CHECK_TYPE (memchr (SDATA (object), '\0', SBYTES (object)) == NULL,
Qstring_without_embedded_nulls_p, object);
}
static void
au_play (struct sound *s, struct sound_device *sd)
{
struct au_header *header = (struct au_header *) s->header;
sd->sample_size = 0;
sd->sample_rate = header->sample_rate;
sd->bps = 0;
sd->channels = header->channels;
sd->choose_format (sd, s);
sd->configure (sd);
if (STRINGP (s->data))
sd->write (sd, SSDATA (s->data) + header->data_offset,
SBYTES (s->data) - header->data_offset);
else
{
int blksize = sd->period_size ? sd->period_size (sd) : 2048;
char *buffer;
int nbytes;
/* Seek */
lseek (s->fd, header->data_offset, SEEK_SET);
/* Copy sound data to the device. */
buffer = (char *) alloca (blksize);
while ((nbytes = emacs_read (s->fd, buffer, blksize)) > 0)
sd->write (sd, buffer, nbytes);
if (nbytes < 0)
sound_perror ("Error reading sound file");
}
}
static HGLOBAL
convert_to_handle_as_ascii (void)
{
HGLOBAL htext = NULL;
int nbytes;
int truelen;
unsigned char *src;
unsigned char *dst;
ONTRACE (fprintf (stderr, "convert_to_handle_as_ascii\n"));
nbytes = SBYTES (current_text) + 1;
src = SDATA (current_text);
/* We need to add to the size the number of LF chars where we have
to insert CR chars (the standard CF_TEXT clipboard format uses
CRLF line endings, while Emacs uses just LF internally). */
truelen = nbytes + current_num_nls;
if ((htext = GlobalAlloc (GMEM_MOVEABLE | GMEM_DDESHARE, truelen)) == NULL)
return NULL;
if ((dst = (unsigned char *) GlobalLock (htext)) == NULL)
{
GlobalFree (htext);
return NULL;
}
/* convert to CRLF line endings expected by clipboard */
while (1)
{
unsigned char *next;
/* copy next line or remaining bytes including '\0' */
next = _memccpy (dst, src, '\n', nbytes);
if (next)
{
/* copied one line ending with '\n' */
int copied = next - dst;
nbytes -= copied;
src += copied;
/* insert '\r' before '\n' */
next[-1] = '\r';
next[0] = '\n';
dst = next + 1;
}
else
/* copied remaining partial line -> now finished */
break;
}
GlobalUnlock (htext);
return htext;
}
static void
fill_in_lock_file_name (char *lockfile, Lisp_Object fn)
{
char *last_slash = memrchr (SSDATA (fn), '/', SBYTES (fn));
char *base = last_slash + 1;
ptrdiff_t dirlen = base - SSDATA (fn);
memcpy (lockfile, SSDATA (fn), dirlen);
lockfile[dirlen] = '.';
lockfile[dirlen + 1] = '#';
strcpy (lockfile + dirlen + 2, base);
}
static void
wav_play (struct sound *s, struct sound_device *sd)
{
struct wav_header *header = (struct wav_header *) s->header;
/* Let the device choose a suitable device-dependent format
for the file. */
sd->choose_format (sd, s);
/* Configure the device. */
sd->sample_size = header->sample_size;
sd->sample_rate = header->sample_rate;
sd->bps = header->bytes_per_second;
sd->channels = header->channels;
sd->configure (sd);
/* Copy sound data to the device. The WAV file specification is
actually more complex. This simple scheme worked with all WAV
files I found so far. If someone feels inclined to implement the
whole RIFF-WAVE spec, please do. */
if (STRINGP (s->data))
sd->write (sd, SSDATA (s->data) + sizeof *header,
SBYTES (s->data) - sizeof *header);
else
{
char *buffer;
int nbytes = 0;
int blksize = sd->period_size ? sd->period_size (sd) : 2048;
int data_left = header->data_length;
buffer = (char *) alloca (blksize);
lseek (s->fd, sizeof *header, SEEK_SET);
while (data_left > 0
&& (nbytes = emacs_read (s->fd, buffer, blksize)) > 0)
{
/* Don't play possible garbage at the end of file */
if (data_left < nbytes) nbytes = data_left;
data_left -= nbytes;
sd->write (sd, buffer, nbytes);
}
if (nbytes < 0)
sound_perror ("Error reading sound file");
}
}
static bool
module_copy_string_contents (emacs_env *env, emacs_value value, char *buffer,
ptrdiff_t *length)
{
MODULE_FUNCTION_BEGIN (false);
Lisp_Object lisp_str = value_to_lisp (value);
if (! STRINGP (lisp_str))
{
module_wrong_type (env, Qstringp, lisp_str);
return false;
}
Lisp_Object lisp_str_utf8 = ENCODE_UTF_8 (lisp_str);
ptrdiff_t raw_size = SBYTES (lisp_str_utf8);
if (raw_size == PTRDIFF_MAX)
{
module_non_local_exit_signal_1 (env, Qoverflow_error, Qnil);
return false;
}
ptrdiff_t required_buf_size = raw_size + 1;
eassert (length != NULL);
if (buffer == NULL)
{
*length = required_buf_size;
return true;
}
eassert (*length >= 0);
if (*length < required_buf_size)
{
*length = required_buf_size;
module_non_local_exit_signal_1 (env, Qargs_out_of_range, Qnil);
return false;
}
*length = required_buf_size;
memcpy (buffer, SDATA (lisp_str_utf8), raw_size + 1);
return true;
}
static Lisp_Object
x_get_foreign_selection (Lisp_Object selection_symbol, Lisp_Object target_type,
Lisp_Object time_stamp, Lisp_Object frame)
{
struct frame *f = XFRAME (frame);
OSStatus err;
Selection sel;
Lisp_Object result = Qnil;
if (!FRAME_LIVE_P (f))
return Qnil;
block_input ();
err = mac_get_selection_from_symbol (selection_symbol, 0, &sel);
if (err == noErr && sel)
{
if (EQ (target_type, QTARGETS))
{
Lisp_Object args[2];
args[0] = list1 (QTARGETS);
args[1] = mac_get_selection_target_list (sel);
result = Fvconcat (2, args);
}
else
{
result = mac_get_selection_value (sel, target_type);
if (STRINGP (result))
Fput_text_property (make_number (0), make_number (SBYTES (result)),
Qforeign_selection, target_type, result);
}
}
unblock_input ();
return result;
}
setup_config ();
current_text = string;
current_coding_system = cfg_coding_system;
current_clipboard_type = cfg_clipboard_type;
current_lcid = cfg_lcid;
current_num_nls = 0;
current_requires_encoding = 0;
block_input ();
/* Check for non-ASCII characters. While we are at it, count the
number of LFs, so we know how many CRs we will have to add later
(just in the case where we can use our internal ASCII rendering,
see code and comment in convert_to_handle_as_ascii() above). */
nbytes = SBYTES (string);
src = SDATA (string);
for (dst = src, end = src+nbytes; dst < end; dst++)
{
if (*dst == '\n')
current_num_nls++;
else if (*dst >= 0x80 || *dst == 0)
{
current_requires_encoding = 1;
break;
}
}
if (!current_requires_encoding)
{
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);
}
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;
/* libSM seems to crash if pwd is missing - see bug#18851. */
if (! get_current_dir_name ())
{
fprintf (stderr, "Disabling session management due to pwd error: %s\n",
emacs_strerror (errno));
return;
}
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
}
}
static Lisp_Object
casify_object (enum case_action flag, Lisp_Object obj)
{
register int c, c1;
register int inword = flag == CASE_DOWN;
/* If the case table is flagged as modified, rescan it. */
if (NILP (XCHAR_TABLE (BVAR (current_buffer, downcase_table))->extras[1]))
Fset_case_table (BVAR (current_buffer, downcase_table));
if (INTEGERP (obj))
{
int flagbits = (CHAR_ALT | CHAR_SUPER | CHAR_HYPER
| CHAR_SHIFT | CHAR_CTL | CHAR_META);
int flags = XINT (obj) & flagbits;
int multibyte = ! NILP (BVAR (current_buffer, enable_multibyte_characters));
/* If the character has higher bits set
above the flags, return it unchanged.
It is not a real character. */
if ((unsigned) XFASTINT (obj) > (unsigned) flagbits)
return obj;
c1 = XFASTINT (obj) & ~flagbits;
/* FIXME: Even if enable-multibyte-characters is nil, we may
manipulate multibyte chars. This means we have a bug for latin-1
chars since when we receive an int 128-255 we can't tell whether
it's an eight-bit byte or a latin-1 char. */
if (c1 >= 256)
multibyte = 1;
if (! multibyte)
MAKE_CHAR_MULTIBYTE (c1);
c = downcase (c1);
if (inword)
XSETFASTINT (obj, c | flags);
else if (c == (XFASTINT (obj) & ~flagbits))
{
if (! inword)
c = upcase1 (c1);
if (! multibyte)
MAKE_CHAR_UNIBYTE (c);
XSETFASTINT (obj, c | flags);
}
return obj;
}
if (!STRINGP (obj))
wrong_type_argument (Qchar_or_string_p, obj);
else if (!STRING_MULTIBYTE (obj))
{
EMACS_INT i;
EMACS_INT size = SCHARS (obj);
obj = Fcopy_sequence (obj);
for (i = 0; i < size; i++)
{
c = SREF (obj, i);
MAKE_CHAR_MULTIBYTE (c);
c1 = c;
if (inword && flag != CASE_CAPITALIZE_UP)
c = downcase (c);
else if (!uppercasep (c)
&& (!inword || flag != CASE_CAPITALIZE_UP))
c = upcase1 (c1);
if ((int) flag >= (int) CASE_CAPITALIZE)
inword = (SYNTAX (c) == Sword);
if (c != c1)
{
MAKE_CHAR_UNIBYTE (c);
/* If the char can't be converted to a valid byte, just don't
change it. */
if (c >= 0 && c < 256)
SSET (obj, i, c);
}
}
return obj;
}
else
{
EMACS_INT i, i_byte, size = SCHARS (obj);
int len;
USE_SAFE_ALLOCA;
unsigned char *dst, *o;
/* Over-allocate by 12%: this is a minor overhead, but should be
sufficient in 99.999% of the cases to avoid a reallocation. */
EMACS_INT o_size = SBYTES (obj) + SBYTES (obj) / 8 + MAX_MULTIBYTE_LENGTH;
SAFE_ALLOCA (dst, void *, o_size);
o = dst;
for (i = i_byte = 0; i < size; i++, i_byte += len)
{
if ((o - dst) + MAX_MULTIBYTE_LENGTH > o_size)
{ /* Not enough space for the next char: grow the destination. */
unsigned char *old_dst = dst;
o_size += o_size; /* Probably overkill, but extremely rare. */
SAFE_ALLOCA (dst, void *, o_size);
memcpy (dst, old_dst, o - old_dst);
o = dst + (o - old_dst);
}
c = STRING_CHAR_AND_LENGTH (SDATA (obj) + i_byte, len);
if (inword && flag != CASE_CAPITALIZE_UP)
c = downcase (c);
else if (!uppercasep (c)
&& (!inword || flag != CASE_CAPITALIZE_UP))
c = upcase1 (c);
if ((int) flag >= (int) CASE_CAPITALIZE)
inword = (SYNTAX (c) == Sword);
o += CHAR_STRING (c, o);
}
eassert (o - dst <= o_size);
obj = make_multibyte_string ((char *) dst, size, o - dst);
SAFE_FREE ();
return obj;
}
}
static HGLOBAL
convert_to_handle_as_coded (Lisp_Object coding_system)
{
HGLOBAL htext = NULL, htext2;
int nbytes;
unsigned char *src;
unsigned char *dst = NULL;
int bufsize;
struct coding_system coding;
Lisp_Object string = Qnil;
ONTRACE (fprintf (stderr, "convert_to_handle_as_coded: %s\n",
SDATA (SYMBOL_NAME (coding_system))));
setup_coding_system (Fcheck_coding_system (coding_system), &coding);
coding.src_multibyte = 1;
coding.dst_multibyte = 0;
/* Need to set COMPOSITION_DISABLED, otherwise Emacs crashes in
encode_coding_iso2022 trying to dereference a null pointer. */
coding.composing = COMPOSITION_DISABLED;
if (coding.type == coding_type_iso2022)
coding.flags |= CODING_FLAG_ISO_SAFE;
coding.mode |= CODING_MODE_LAST_BLOCK;
/* Force DOS line-ends. */
coding.eol_type = CODING_EOL_CRLF;
if (SYMBOLP (coding.pre_write_conversion)
&& !NILP (Ffboundp (coding.pre_write_conversion)))
string = run_pre_post_conversion_on_str (current_text, &coding, 1);
else
string = current_text;
nbytes = SBYTES (string);
src = SDATA (string);
bufsize = encoding_buffer_size (&coding, nbytes) +2;
htext = GlobalAlloc (GMEM_MOVEABLE | GMEM_DDESHARE, bufsize);
if (htext != NULL)
dst = (unsigned char *) GlobalLock (htext);
if (dst != NULL)
{
encode_coding (&coding, src, dst, nbytes, bufsize-2);
/* Add the string terminator. Add two NULs in case we are
producing Unicode here. */
dst[coding.produced] = dst[coding.produced+1] = '\0';
}
if (dst != NULL)
GlobalUnlock (htext);
if (htext != NULL)
{
/* Shrink data block to actual size. */
htext2 = GlobalReAlloc (htext, coding.produced+2,
GMEM_MOVEABLE | GMEM_DDESHARE);
if (htext2 != NULL) htext = htext2;
}
return htext;
}
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], *vp;
int val_idx = 0, vp_idx = 0;
int props_idx = 0;
int i;
char *smid_opt, *chdir_opt = NULL;
Lisp_Object user_login_name = Fuser_login_name (Qnil);
/* Must have these. */
if (! STRINGP (Vinvocation_name) || ! STRINGP (user_login_name))
return;
/* How to start a new instance of Emacs. */
props[props_idx] = &prop_ptr[props_idx];
props[props_idx]->name = xstrdup (SmCloneCommand);
props[props_idx]->type = xstrdup (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 = xstrdup (SmProgram);
props[props_idx]->type = xstrdup (SmARRAY8);
props[props_idx]->num_vals = 1;
props[props_idx]->vals = &values[val_idx++];
props[props_idx]->vals[0].length = SBYTES (Vinvocation_name);
props[props_idx]->vals[0].value = SDATA (Vinvocation_name);
++props_idx;
/* User id. */
props[props_idx] = &prop_ptr[props_idx];
props[props_idx]->name = xstrdup (SmUserID);
props[props_idx]->type = xstrdup (SmARRAY8);
props[props_idx]->num_vals = 1;
props[props_idx]->vals = &values[val_idx++];
props[props_idx]->vals[0].length = SBYTES (user_login_name);
props[props_idx]->vals[0].value = SDATA (user_login_name);
++props_idx;
char *cwd = get_current_dir_name ();
if (cwd)
{
props[props_idx] = &prop_ptr[props_idx];
props[props_idx]->name = xstrdup (SmCurrentDirectory);
props[props_idx]->type = xstrdup (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;
}
/* How to restart Emacs. */
props[props_idx] = &prop_ptr[props_idx];
props[props_idx]->name = xstrdup (SmRestartCommand);
props[props_idx]->type = xstrdup (SmLISTofARRAY8);
/* /path/to/emacs, --smid=xxx --no-splash --chdir=dir ... */
if (INT_ADD_WRAPV (initial_argc, 3, &i))
memory_full (SIZE_MAX);
props[props_idx]->num_vals = i;
vp = xnmalloc (i, sizeof *vp);
props[props_idx]->vals = vp;
props[props_idx]->vals[vp_idx].length = strlen (emacs_program);
props[props_idx]->vals[vp_idx++].value = emacs_program;
smid_opt = xmalloc (strlen (SMID_OPT) + strlen (client_id) + 1);
strcpy (stpcpy (smid_opt, SMID_OPT), client_id);
props[props_idx]->vals[vp_idx].length = strlen (smid_opt);
props[props_idx]->vals[vp_idx++].value = smid_opt;
props[props_idx]->vals[vp_idx].length = strlen (NOSPLASH_OPT);
props[props_idx]->vals[vp_idx++].value = NOSPLASH_OPT;
if (cwd)
{
chdir_opt = xmalloc (strlen (CHDIR_OPT) + strlen (cwd) + 1);
strcpy (stpcpy (chdir_opt, CHDIR_OPT), cwd);
props[props_idx]->vals[vp_idx].length = strlen (chdir_opt);
props[props_idx]->vals[vp_idx++].value = chdir_opt;
}
for (i = 1; i < initial_argc; ++i)
{
props[props_idx]->vals[vp_idx].length = strlen (initial_argv[i]);
props[props_idx]->vals[vp_idx++].value = initial_argv[i];
}
++props_idx;
SmcSetProperties (smcConn, props_idx, props);
xfree (smid_opt);
xfree (chdir_opt);
xfree (cwd);
xfree (vp);
for (i = 0; i < props_idx; ++i)
{
xfree (props[i]->type);
xfree (props[i]->name);
}
/* 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);
}
}
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));
}
}
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;
}
