diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/alloc.c | 200 | ||||
| -rw-r--r-- | src/callint.c | 1 | ||||
| -rw-r--r-- | src/callproc.c | 40 | ||||
| -rw-r--r-- | src/charset.c | 20 | ||||
| -rw-r--r-- | src/cm.c | 1 | ||||
| -rw-r--r-- | src/dired.c | 149 | ||||
| -rw-r--r-- | src/doc.c | 2 | ||||
| -rw-r--r-- | src/emacs.c | 3 | ||||
| -rw-r--r-- | src/eval.c | 9 | ||||
| -rw-r--r-- | src/fileio.c | 478 | ||||
| -rw-r--r-- | src/filelock.c | 86 | ||||
| -rw-r--r-- | src/fns.c | 3 | ||||
| -rw-r--r-- | src/lisp.h | 11 | ||||
| -rw-r--r-- | src/lread.c | 21 | ||||
| -rw-r--r-- | src/print.c | 100 | ||||
| -rw-r--r-- | src/profiler.c | 12 | ||||
| -rw-r--r-- | src/term.c | 1 | ||||
| -rw-r--r-- | src/w32.c | 29 | ||||
| -rw-r--r-- | src/w32fns.c | 4 | ||||
| -rw-r--r-- | src/w32font.c | 127 | ||||
| -rw-r--r-- | src/xdisp.c | 8 | ||||
| -rw-r--r-- | src/xwidget.c | 219 |
22 files changed, 816 insertions, 708 deletions
diff --git a/src/alloc.c b/src/alloc.c index 2d490f3bb75..9fbd0d05739 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -224,7 +224,7 @@ struct emacs_globals globals; /* maybe_gc collects garbage if this goes negative. */ -intmax_t consing_until_gc; +EMACS_INT consing_until_gc; #ifdef HAVE_PDUMPER /* Number of finalizers run: used to loop over GC until we stop @@ -238,10 +238,17 @@ bool gc_in_progress; /* System byte and object counts reported by GC. */ +/* Assume byte counts fit in uintptr_t and object counts fit into + intptr_t. */ typedef uintptr_t byte_ct; typedef intptr_t object_ct; -/* Number of live and free conses etc. */ +/* Large-magnitude value for a threshold count, which fits in EMACS_INT. + Using only half the EMACS_INT range avoids overflow hassles. + There is no need to fit these counts into fixnums. */ +#define HI_THRESHOLD (EMACS_INT_MAX / 2) + +/* Number of live and free conses etc. counted by the most-recent GC. */ static struct gcstat { @@ -299,7 +306,7 @@ static intptr_t garbage_collection_inhibited; /* The GC threshold in bytes, the last time it was calculated from gc-cons-threshold and gc-cons-percentage. */ -static intmax_t gc_threshold; +static EMACS_INT gc_threshold; /* If nonzero, this is a warning delivered by malloc and not yet displayed. */ @@ -536,6 +543,15 @@ XFLOAT_INIT (Lisp_Object f, double n) XFLOAT (f)->u.data = n; } +/* Account for allocation of NBYTES in the heap. This is a separate + function to avoid hassles with implementation-defined conversion + from unsigned to signed types. */ +static void +tally_consing (ptrdiff_t nbytes) +{ + consing_until_gc -= nbytes; +} + #ifdef DOUG_LEA_MALLOC static bool pointers_fit_in_lispobj_p (void) @@ -560,7 +576,7 @@ struct Lisp_Finalizer finalizers; /* Head of a circularly-linked list of finalizers that must be invoked because we deemed them unreachable. This list must be global, and - not a local inside garbage_collect_1, in case we GC again while + not a local inside garbage_collect, in case we GC again while running finalizers. */ struct Lisp_Finalizer doomed_finalizers; @@ -1366,16 +1382,14 @@ make_interval (void) newi->next = interval_block; interval_block = newi; interval_block_index = 0; - gcstat.total_free_intervals += INTERVAL_BLOCK_SIZE; } val = &interval_block->intervals[interval_block_index++]; } MALLOC_UNBLOCK_INPUT; - consing_until_gc -= sizeof (struct interval); + tally_consing (sizeof (struct interval)); intervals_consed++; - gcstat.total_free_intervals--; RESET_INTERVAL (val); val->gcmarkbit = 0; return val; @@ -1730,8 +1744,6 @@ allocate_string (void) NEXT_FREE_LISP_STRING (s) = string_free_list; string_free_list = ptr_bounds_clip (s, sizeof *s); } - - gcstat.total_free_strings += STRING_BLOCK_SIZE; } check_string_free_list (); @@ -1742,10 +1754,8 @@ allocate_string (void) MALLOC_UNBLOCK_INPUT; - gcstat.total_free_strings--; - gcstat.total_strings++; ++strings_consed; - consing_until_gc -= sizeof *s; + tally_consing (sizeof *s); #ifdef GC_CHECK_STRING_BYTES if (!noninteractive) @@ -1865,7 +1875,7 @@ allocate_string_data (struct Lisp_String *s, old_data->string = NULL; } - consing_until_gc -= needed; + tally_consing (needed); } @@ -2461,7 +2471,6 @@ make_float (double float_value) memset (new->gcmarkbits, 0, sizeof new->gcmarkbits); float_block = new; float_block_index = 0; - gcstat.total_free_floats += FLOAT_BLOCK_SIZE; } XSETFLOAT (val, &float_block->floats[float_block_index]); float_block_index++; @@ -2471,9 +2480,8 @@ make_float (double float_value) XFLOAT_INIT (val, float_value); eassert (!XFLOAT_MARKED_P (XFLOAT (val))); - consing_until_gc -= sizeof (struct Lisp_Float); + tally_consing (sizeof (struct Lisp_Float)); floats_consed++; - gcstat.total_free_floats--; return val; } @@ -2543,9 +2551,8 @@ free_cons (struct Lisp_Cons *ptr) ptr->u.s.u.chain = cons_free_list; ptr->u.s.car = dead_object (); cons_free_list = ptr; - if (INT_ADD_WRAPV (consing_until_gc, sizeof *ptr, &consing_until_gc)) - consing_until_gc = INTMAX_MAX; - gcstat.total_free_conses++; + ptrdiff_t nbytes = sizeof *ptr; + tally_consing (-nbytes); } DEFUN ("cons", Fcons, Scons, 2, 2, 0, @@ -2565,26 +2572,12 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0, { if (cons_block_index == CONS_BLOCK_SIZE) { - /* Maximum number of conses that should be active at any - given time, so that list lengths fit into a ptrdiff_t and - into a fixnum. */ - ptrdiff_t max_conses = min (PTRDIFF_MAX, MOST_POSITIVE_FIXNUM); - - /* This check is typically optimized away, as a runtime - check is needed only on weird platforms where a count of - distinct conses might not fit. */ - if (max_conses < INTPTR_MAX / sizeof (struct Lisp_Cons) - && (max_conses - CONS_BLOCK_SIZE - < gcstat.total_free_conses + gcstat.total_conses)) - memory_full (sizeof (struct cons_block)); - struct cons_block *new = lisp_align_malloc (sizeof *new, MEM_TYPE_CONS); memset (new->gcmarkbits, 0, sizeof new->gcmarkbits); new->next = cons_block; cons_block = new; cons_block_index = 0; - gcstat.total_free_conses += CONS_BLOCK_SIZE; } XSETCONS (val, &cons_block->conses[cons_block_index]); cons_block_index++; @@ -2596,7 +2589,6 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0, XSETCDR (val, cdr); eassert (!XCONS_MARKED_P (XCONS (val))); consing_until_gc -= sizeof (struct Lisp_Cons); - gcstat.total_free_conses--; cons_cells_consed++; return val; } @@ -2855,7 +2847,6 @@ setup_on_free_list (struct Lisp_Vector *v, ptrdiff_t nbytes) eassert (vindex < VECTOR_MAX_FREE_LIST_INDEX); set_next_vector (v, vector_free_lists[vindex]); vector_free_lists[vindex] = v; - gcstat.total_free_vector_slots += nbytes / word_size; } /* Get a new vector block. */ @@ -2903,7 +2894,6 @@ allocate_vector_from_block (ptrdiff_t nbytes) { vector = vector_free_lists[index]; vector_free_lists[index] = next_vector (vector); - gcstat.total_free_vector_slots -= nbytes / word_size; return vector; } @@ -2917,7 +2907,6 @@ allocate_vector_from_block (ptrdiff_t nbytes) /* This vector is larger than requested. */ vector = vector_free_lists[index]; vector_free_lists[index] = next_vector (vector); - gcstat.total_free_vector_slots -= nbytes / word_size; /* Excess bytes are used for the smaller vector, which should be set on an appropriate free list. */ @@ -3092,7 +3081,10 @@ sweep_vectors (void) space was coalesced into the only free vector. */ free_this_block = true; else - setup_on_free_list (vector, total_bytes); + { + setup_on_free_list (vector, total_bytes); + gcstat.total_free_vector_slots += total_bytes / word_size; + } } } @@ -3177,7 +3169,7 @@ allocate_vectorlike (ptrdiff_t len) if (find_suspicious_object_in_range (p, (char *) p + nbytes)) emacs_abort (); - consing_until_gc -= nbytes; + tally_consing (nbytes); vector_cells_consed += len; MALLOC_UNBLOCK_INPUT; @@ -3454,7 +3446,6 @@ Its value is void, and its function definition and property list are nil. */) new->next = symbol_block; symbol_block = new; symbol_block_index = 0; - gcstat.total_free_symbols += SYMBOL_BLOCK_SIZE; } XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index]); symbol_block_index++; @@ -3463,9 +3454,8 @@ Its value is void, and its function definition and property list are nil. */) MALLOC_UNBLOCK_INPUT; init_symbol (val, name); - consing_until_gc -= sizeof (struct Lisp_Symbol); + tally_consing (sizeof (struct Lisp_Symbol)); symbols_consed++; - gcstat.total_free_symbols--; return val; } @@ -5503,7 +5493,7 @@ staticpro (Lisp_Object const *varaddress) static void allow_garbage_collection (intmax_t consing) { - consing_until_gc = consing - (INTMAX_MAX - consing_until_gc); + consing_until_gc = consing - (HI_THRESHOLD - consing_until_gc); garbage_collection_inhibited--; } @@ -5513,7 +5503,7 @@ inhibit_garbage_collection (void) ptrdiff_t count = SPECPDL_INDEX (); record_unwind_protect_intmax (allow_garbage_collection, consing_until_gc); garbage_collection_inhibited++; - consing_until_gc = INTMAX_MAX; + consing_until_gc = HI_THRESHOLD; return count; } @@ -5723,7 +5713,7 @@ visit_buffer_root (struct gc_root_visitor visitor, There are other GC roots of course, but these roots are dynamic runtime data structures that pdump doesn't care about and so we can - continue to mark those directly in garbage_collect_1. */ + continue to mark those directly in garbage_collect. */ void visit_static_gc_roots (struct gc_root_visitor visitor) { @@ -5753,8 +5743,7 @@ mark_object_root_visitor (Lisp_Object const *root_ptr, } /* List of weak hash tables we found during marking the Lisp heap. - Will be NULL on entry to garbage_collect_1 and after it - returns. */ + NULL on entry to garbage_collect and after it returns. */ static struct Lisp_Hash_Table *weak_hash_tables; NO_INLINE /* For better stack traces */ @@ -5788,11 +5777,13 @@ mark_and_sweep_weak_table_contents (void) } } -/* Return the number of bytes to cons between GCs, assuming - gc-cons-threshold is THRESHOLD and gc-cons-percentage is - PERCENTAGE. */ -static intmax_t -consing_threshold (intmax_t threshold, Lisp_Object percentage) +/* Return the number of bytes to cons between GCs, given THRESHOLD and + PERCENTAGE. When calculating a threshold based on PERCENTAGE, + assume SINCE_GC bytes have been allocated since the most recent GC. + The returned value is positive and no greater than HI_THRESHOLD. */ +static EMACS_INT +consing_threshold (intmax_t threshold, Lisp_Object percentage, + intmax_t since_gc) { if (!NILP (Vmemory_full)) return memory_full_cons_threshold; @@ -5802,42 +5793,33 @@ consing_threshold (intmax_t threshold, Lisp_Object percentage) if (FLOATP (percentage)) { double tot = (XFLOAT_DATA (percentage) - * total_bytes_of_live_objects ()); + * (total_bytes_of_live_objects () + since_gc)); if (threshold < tot) { - if (tot < INTMAX_MAX) - threshold = tot; + if (tot < HI_THRESHOLD) + return tot; else - threshold = INTMAX_MAX; + return HI_THRESHOLD; } } - return threshold; + return min (threshold, HI_THRESHOLD); } } -/* Adjust consing_until_gc, assuming gc-cons-threshold is THRESHOLD and - gc-cons-percentage is PERCENTAGE. */ -static Lisp_Object +/* Adjust consing_until_gc and gc_threshold, given THRESHOLD and PERCENTAGE. + Return the updated consing_until_gc. */ + +static EMACS_INT bump_consing_until_gc (intmax_t threshold, Lisp_Object percentage) { - /* If consing_until_gc is negative leave it alone, since this prevents - negative integer overflow and a GC would have been done soon anyway. */ - if (0 <= consing_until_gc) - { - threshold = consing_threshold (threshold, percentage); - intmax_t sum; - if (INT_ADD_WRAPV (consing_until_gc, threshold - gc_threshold, &sum)) - { - /* Scale the threshold down so that consing_until_gc does - not overflow. */ - sum = INTMAX_MAX; - threshold = INTMAX_MAX - consing_until_gc + gc_threshold; - } - consing_until_gc = sum; - gc_threshold = threshold; - } - - return Qnil; + /* Guesstimate that half the bytes allocated since the most + recent GC are still in use. */ + EMACS_INT since_gc = (gc_threshold - consing_until_gc) >> 1; + EMACS_INT new_gc_threshold = consing_threshold (threshold, percentage, + since_gc); + consing_until_gc += new_gc_threshold - gc_threshold; + gc_threshold = new_gc_threshold; + return consing_until_gc; } /* Watch changes to gc-cons-threshold. */ @@ -5848,7 +5830,8 @@ watch_gc_cons_threshold (Lisp_Object symbol, Lisp_Object newval, intmax_t threshold; if (! (INTEGERP (newval) && integer_to_intmax (newval, &threshold))) return Qnil; - return bump_consing_until_gc (threshold, Vgc_cons_percentage); + bump_consing_until_gc (threshold, Vgc_cons_percentage); + return Qnil; } /* Watch changes to gc-cons-percentage. */ @@ -5856,24 +5839,34 @@ static Lisp_Object watch_gc_cons_percentage (Lisp_Object symbol, Lisp_Object newval, Lisp_Object operation, Lisp_Object where) { - return bump_consing_until_gc (gc_cons_threshold, newval); + bump_consing_until_gc (gc_cons_threshold, newval); + return Qnil; +} + +/* It may be time to collect garbage. Recalculate consing_until_gc, + since it might depend on current usage, and do the garbage + collection if the recalculation says so. */ +void +maybe_garbage_collect (void) +{ + if (bump_consing_until_gc (gc_cons_threshold, Vgc_cons_percentage) < 0) + garbage_collect (); } /* Subroutine of Fgarbage_collect that does most of the work. */ -static bool -garbage_collect_1 (struct gcstat *gcst) +void +garbage_collect (void) { struct buffer *nextb; char stack_top_variable; bool message_p; ptrdiff_t count = SPECPDL_INDEX (); struct timespec start; - byte_ct tot_before = 0; eassert (weak_hash_tables == NULL); if (garbage_collection_inhibited) - return false; + return; /* Record this function, so it appears on the profiler's backtraces. */ record_in_backtrace (QAutomatic_GC, 0, 0); @@ -5883,14 +5876,15 @@ garbage_collect_1 (struct gcstat *gcst) FOR_EACH_BUFFER (nextb) compact_buffer (nextb); - if (profiler_memory_running) - tot_before = total_bytes_of_live_objects (); + byte_ct tot_before = (profiler_memory_running + ? total_bytes_of_live_objects () + : (byte_ct) -1); start = current_timespec (); /* In case user calls debug_print during GC, don't let that cause a recursive GC. */ - consing_until_gc = INTMAX_MAX; + consing_until_gc = HI_THRESHOLD; /* Save what's currently displayed in the echo area. Don't do that if we are GC'ing because we've run out of memory, since @@ -6002,7 +5996,7 @@ garbage_collect_1 (struct gcstat *gcst) unblock_input (); consing_until_gc = gc_threshold - = consing_threshold (gc_cons_threshold, Vgc_cons_percentage); + = consing_threshold (gc_cons_threshold, Vgc_cons_percentage, 0); if (garbage_collection_messages && NILP (Vmemory_full)) { @@ -6014,8 +6008,6 @@ garbage_collect_1 (struct gcstat *gcst) unbind_to (count, Qnil); - *gcst = gcstat; - /* GC is complete: now we can run our finalizer callbacks. */ run_finalizers (&doomed_finalizers); @@ -6029,29 +6021,21 @@ garbage_collect_1 (struct gcstat *gcst) /* Accumulate statistics. */ if (FLOATP (Vgc_elapsed)) { - struct timespec since_start = timespec_sub (current_timespec (), start); - Vgc_elapsed = make_float (XFLOAT_DATA (Vgc_elapsed) - + timespectod (since_start)); + static struct timespec gc_elapsed; + gc_elapsed = timespec_add (gc_elapsed, + timespec_sub (current_timespec (), start)); + Vgc_elapsed = make_float (timespectod (gc_elapsed)); } gcs_done++; /* Collect profiling data. */ - if (profiler_memory_running) + if (tot_before != (byte_ct) -1) { byte_ct tot_after = total_bytes_of_live_objects (); - byte_ct swept = tot_before <= tot_after ? 0 : tot_before - tot_after; - malloc_probe (min (swept, SIZE_MAX)); + if (tot_after < tot_before) + malloc_probe (min (tot_before - tot_after, SIZE_MAX)); } - - return true; -} - -void -garbage_collect (void) -{ - struct gcstat gcst; - garbage_collect_1 (&gcst); } DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "", @@ -6071,10 +6055,12 @@ returns nil, because real GC can't be done. See Info node `(elisp)Garbage Collection'. */) (void) { - struct gcstat gcst; - if (!garbage_collect_1 (&gcst)) + if (garbage_collection_inhibited) return Qnil; + garbage_collect (); + struct gcstat gcst = gcstat; + Lisp_Object total[] = { list4 (Qconses, make_fixnum (sizeof (struct Lisp_Cons)), make_int (gcst.total_conses), diff --git a/src/callint.c b/src/callint.c index d76836f32b2..449b5048609 100644 --- a/src/callint.c +++ b/src/callint.c @@ -35,7 +35,6 @@ static Lisp_Object point_marker; /* String for the prompt text used in Fcall_interactively. */ static Lisp_Object callint_message; -/* ARGSUSED */ DEFUN ("interactive", Finteractive, Sinteractive, 0, UNEVALLED, 0, doc: /* Specify a way of parsing arguments for interactive use of a function. For example, write diff --git a/src/callproc.c b/src/callproc.c index b296bdb088b..dbbf15c792a 100644 --- a/src/callproc.c +++ b/src/callproc.c @@ -108,11 +108,8 @@ static Lisp_Object call_process (ptrdiff_t, Lisp_Object *, int, ptrdiff_t); Lisp_Object encode_current_directory (void) { - Lisp_Object dir; - - dir = BVAR (current_buffer, directory); - - dir = Funhandled_file_name_directory (dir); + Lisp_Object curdir = BVAR (current_buffer, directory); + Lisp_Object dir = Funhandled_file_name_directory (curdir); /* If the file name handler says that dir is unreachable, use a sensible default. */ @@ -120,17 +117,10 @@ encode_current_directory (void) dir = build_string ("~"); dir = expand_and_dir_to_file (dir); - - if (NILP (Ffile_accessible_directory_p (dir))) - report_file_error ("Setting current directory", - BVAR (current_buffer, directory)); - - /* Remove "/:" from DIR and encode it. */ dir = ENCODE_FILE (remove_slash_colon (dir)); if (! file_accessible_directory_p (dir)) - report_file_error ("Setting current directory", - BVAR (current_buffer, directory)); + report_file_error ("Setting current directory", curdir); return dir; } @@ -1570,20 +1560,19 @@ init_callproc (void) source directory. */ if (data_dir == 0) { - Lisp_Object tem, tem1, srcdir; + Lisp_Object tem, srcdir; Lisp_Object lispdir = Fcar (decode_env_path (0, PATH_DUMPLOADSEARCH, 0)); srcdir = Fexpand_file_name (build_string ("../src/"), lispdir); tem = Fexpand_file_name (build_string ("NEWS"), Vdata_directory); - tem1 = Ffile_exists_p (tem); - if (!NILP (Fequal (srcdir, Vinvocation_directory)) || NILP (tem1)) + if (!NILP (Fequal (srcdir, Vinvocation_directory)) + || !file_access_p (SSDATA (tem), F_OK)) { Lisp_Object newdir; newdir = Fexpand_file_name (build_string ("../etc/"), lispdir); tem = Fexpand_file_name (build_string ("NEWS"), newdir); - tem1 = Ffile_exists_p (tem); - if (!NILP (tem1)) + if (file_access_p (SSDATA (tem), F_OK)) Vdata_directory = newdir; } } @@ -1605,9 +1594,22 @@ init_callproc (void) Lisp_Object gamedir = Qnil; if (PATH_GAME) { - Lisp_Object path_game = build_unibyte_string (PATH_GAME); + const char *cpath_game = PATH_GAME; +#ifdef WINDOWSNT + /* On MS-Windows, PATH_GAME normally starts with a literal + "%emacs_dir%", so it will never work without some tweaking. */ + cpath_game = w32_relocate (cpath_game); +#endif + Lisp_Object path_game = build_unibyte_string (cpath_game); if (file_accessible_directory_p (path_game)) gamedir = path_game; + else if (errno != ENOENT && errno != ENOTDIR +#ifdef DOS_NT + /* DOS/Windows sometimes return EACCES for bad file names */ + && errno != EACCES +#endif + ) + dir_warning ("game dir", path_game); } Vshared_game_score_directory = gamedir; } diff --git a/src/charset.c b/src/charset.c index 8c54381dc48..93206aa29b0 100644 --- a/src/charset.c +++ b/src/charset.c @@ -2292,14 +2292,18 @@ init_charset (void) { /* This used to be non-fatal (dir_warning), but it should not happen, and if it does sooner or later it will cause some - obscure problem (eg bug#6401), so better abort. */ - fprintf (stderr, "Error: charsets directory not found:\n\ -%s\n\ -Emacs will not function correctly without the character map files.\n%s\ -Please check your installation!\n", - SDATA (tempdir), - egetenv("EMACSDATA") ? "The EMACSDATA environment \ -variable is set, maybe it has the wrong value?\n" : ""); + obscure problem (eg bug#6401), so better exit. */ + fprintf (stderr, + ("Error: %s: %s\n" + "Emacs will not function correctly " + "without the character map files.\n" + "%s" + "Please check your installation!\n"), + SDATA (tempdir), strerror (errno), + (egetenv ("EMACSDATA") + ? ("The EMACSDATA environment variable is set. " + "Maybe it has the wrong value?\n") + : "")); exit (1); } @@ -30,7 +30,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ int cost; /* sums up costs */ -/* ARGSUSED */ int evalcost (int c) { diff --git a/src/dired.c b/src/dired.c index 7bc4b83fd77..3768b6dbb7c 100644 --- a/src/dired.c +++ b/src/dired.c @@ -79,9 +79,9 @@ dirent_type (struct dirent *dp) } static DIR * -open_directory (Lisp_Object dirname, int *fdp) +open_directory (Lisp_Object dirname, Lisp_Object encoded_dirname, int *fdp) { - char *name = SSDATA (dirname); + char *name = SSDATA (encoded_dirname); DIR *d; int fd, opendir_errno; @@ -167,38 +167,31 @@ 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 + if (!NILP (match)) + CHECK_STRING (match); /* 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); + Lisp_Object 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); + Lisp_Object encoded_dirfilename = ENCODE_FILE (dirfilename); int fd; - DIR *d = open_directory (dirfilename, &fd); + DIR *d = open_directory (dirfilename, encoded_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. */ + ptrdiff_t count = SPECPDL_INDEX (); record_unwind_protect_ptr (directory_files_internal_unwind, d); #ifdef WINDOWSNT + Lisp_Object w32_save = Qnil; if (attrs) { /* Do this only once to avoid doing it (in w32.c:stat) for each @@ -210,7 +203,7 @@ directory_files_internal (Lisp_Object directory, Lisp_Object full, { /* w32.c:stat will notice these bindings and avoid calling GetDriveType for each file. */ - if (is_slow_fs (SSDATA (dirfilename))) + if (is_slow_fs (SSDATA (encoded_dirfilename))) Vw32_get_true_file_attributes = Qnil; else Vw32_get_true_file_attributes = Qt; @@ -218,88 +211,63 @@ directory_files_internal (Lisp_Object directory, Lisp_Object full, } #endif - directory_nbytes = SBYTES (directory); + ptrdiff_t 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; + bool needsep = (directory_nbytes == 0 + || !IS_ANY_SEP (SREF (directory, directory_nbytes - 1))); /* Windows users want case-insensitive wildcards. */ - Lisp_Object case_table = + Lisp_Object case_table = Qnil; #ifdef WINDOWSNT - BVAR (&buffer_defaults, case_canon_table) -#else - Qnil + case_table = BVAR (&buffer_defaults, case_canon_table); #endif - ; - if (!NILP (match)) - CHECK_STRING (match); - - /* Loop reading directory entries. */ + /* Read directory entries and accumulate them into LIST. */ + Lisp_Object list = Qnil; 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. */ + /* This can GC. */ 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 (!NILP (match) + && fast_string_match_internal (match, name, case_table) < 0) + continue; - if (wanted) + Lisp_Object fileattrs UNINIT; + if (attrs) { - 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; + fileattrs = file_attributes (fd, dp->d_name, directory, name, + id_format); + if (NILP (fileattrs)) + continue; + } - 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); + if (!NILP (full)) + { + ptrdiff_t name_nbytes = SBYTES (name); + ptrdiff_t nbytes = directory_nbytes + needsep + name_nbytes; + ptrdiff_t nchars = SCHARS (directory) + needsep + SCHARS (name); + finalname = make_uninit_multibyte_string (nchars, nbytes); + if (nchars == nbytes) + STRING_SET_UNIBYTE (finalname); + memcpy (SDATA (finalname), SDATA (directory), directory_nbytes); + if (needsep) + SSET (finalname, directory_nbytes, DIRECTORY_SEP); + memcpy (SDATA (finalname) + directory_nbytes + needsep, + SDATA (name), name_nbytes); } + else + finalname = name; + + list = Fcons (attrs ? Fcons (finalname, fileattrs) : finalname, list); } closedir (d); @@ -329,14 +297,14 @@ If MATCH is non-nil, mention only file names that match the regexp MATCH. If NOSORT is non-nil, the list is not sorted--its order is unpredictable. Otherwise, the list returned is sorted with `string-lessp'. NOSORT is useful if you plan to sort the result yourself. */) - (Lisp_Object directory, Lisp_Object full, Lisp_Object match, Lisp_Object nosort) + (Lisp_Object directory, Lisp_Object full, Lisp_Object match, + Lisp_Object nosort) { - Lisp_Object handler; directory = Fexpand_file_name (directory, Qnil); /* If the file name has special constructs in it, call the corresponding file name handler. */ - handler = Ffind_file_name_handler (directory, Qdirectory_files); + Lisp_Object handler = Ffind_file_name_handler (directory, Qdirectory_files); if (!NILP (handler)) return call5 (handler, Qdirectory_files, directory, full, match, nosort); @@ -364,14 +332,15 @@ ID-FORMAT specifies the preferred format of attributes uid and gid, see `file-attributes' for further documentation. On MS-Windows, performance depends on `w32-get-true-file-attributes', which see. */) - (Lisp_Object directory, Lisp_Object full, Lisp_Object match, Lisp_Object nosort, Lisp_Object id_format) + (Lisp_Object directory, Lisp_Object full, Lisp_Object match, + Lisp_Object nosort, Lisp_Object id_format) { - Lisp_Object handler; directory = Fexpand_file_name (directory, Qnil); /* If the file name has special constructs in it, call the corresponding file name handler. */ - handler = Ffind_file_name_handler (directory, Qdirectory_files_and_attributes); + Lisp_Object handler + = Ffind_file_name_handler (directory, Qdirectory_files_and_attributes); if (!NILP (handler)) return call6 (handler, Qdirectory_files_and_attributes, directory, full, match, nosort, id_format); @@ -508,7 +477,7 @@ file_name_completion (Lisp_Object file, Lisp_Object dirname, bool all_flag, } } int fd; - DIR *d = open_directory (encoded_dir, &fd); + DIR *d = open_directory (dirname, encoded_dir, &fd); record_unwind_protect_ptr (directory_files_internal_unwind, d); /* Loop reading directory entries. */ @@ -850,7 +819,7 @@ stat_gname (struct stat *st) DEFUN ("file-attributes", Ffile_attributes, Sfile_attributes, 1, 2, 0, doc: /* Return a list of attributes of file FILENAME. -Value is nil if specified file cannot be opened. +Value is nil if specified file does not exist. ID-FORMAT specifies the preferred format of attributes uid and gid (see below) - valid values are `string' and `integer'. The latter is the @@ -970,15 +939,14 @@ file_attributes (int fd, char const *name, information to be accurate. */ w32_stat_get_owner_group = 1; #endif - if (fstatat (fd, name, &s, AT_SYMLINK_NOFOLLOW) == 0) - err = 0; + err = fstatat (fd, name, &s, AT_SYMLINK_NOFOLLOW) == 0 ? 0 : errno; #ifdef WINDOWSNT w32_stat_get_owner_group = 0; #endif } if (err != 0) - return unbind_to (count, Qnil); + return unbind_to (count, file_attribute_errno (filename, err)); Lisp_Object file_type; if (S_ISLNK (s.st_mode)) @@ -987,7 +955,7 @@ file_attributes (int fd, char const *name, symlink is replaced between the call to fstatat and the call to emacs_readlinkat. Detect this race unless the replacement is also a symlink. */ - file_type = emacs_readlinkat (fd, name); + file_type = check_emacs_readlinkat (fd, filename, name); if (NILP (file_type)) return unbind_to (count, Qnil); } @@ -1031,7 +999,8 @@ file_attributes (int fd, char const *name, INT_TO_INTEGER (s.st_dev)); } -DEFUN ("file-attributes-lessp", Ffile_attributes_lessp, Sfile_attributes_lessp, 2, 2, 0, +DEFUN ("file-attributes-lessp", Ffile_attributes_lessp, + Sfile_attributes_lessp, 2, 2, 0, doc: /* Return t if first arg file attributes list is less than second. Comparison is in lexicographic order and case is significant. */) (Lisp_Object f1, Lisp_Object f2) diff --git a/src/doc.c b/src/doc.c index 247be79adaf..b06b87c6114 100644 --- a/src/doc.c +++ b/src/doc.c @@ -136,7 +136,7 @@ get_doc_string (Lisp_Object filepos, bool unibyte, bool definition) } if (fd < 0) { - if (errno == EMFILE || errno == ENFILE) + if (errno != ENOENT && errno != ENOTDIR) report_file_error ("Read error on documentation file", file); SAFE_FREE (); diff --git a/src/emacs.c b/src/emacs.c index 5a526687b14..eb732810db4 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -746,7 +746,7 @@ load_pdump_find_executable (char const *argv0, ptrdiff_t *candidate_size) candidate[path_part_length] = DIRECTORY_SEP; memcpy (candidate + path_part_length + 1, argv0, argv0_length + 1); struct stat st; - if (check_executable (candidate) + if (file_access_p (candidate, X_OK) && stat (candidate, &st) == 0 && S_ISREG (st.st_mode)) return candidate; *candidate = '\0'; @@ -923,7 +923,6 @@ load_pdump (int argc, char **argv) } #endif /* HAVE_PDUMPER */ -/* ARGSUSED */ int main (int argc, char **argv) { diff --git a/src/eval.c b/src/eval.c index 06d5c63f7f7..2bfc16eae0e 100644 --- a/src/eval.c +++ b/src/eval.c @@ -1890,7 +1890,6 @@ verror (const char *m, va_list ap) /* Dump an error message; called like printf. */ -/* VARARGS 1 */ void error (const char *m, ...) { @@ -2649,7 +2648,6 @@ call0 (Lisp_Object fn) } /* Call function fn with 1 argument arg1. */ -/* ARGSUSED */ Lisp_Object call1 (Lisp_Object fn, Lisp_Object arg1) { @@ -2657,7 +2655,6 @@ call1 (Lisp_Object fn, Lisp_Object arg1) } /* Call function fn with 2 arguments arg1, arg2. */ -/* ARGSUSED */ Lisp_Object call2 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2) { @@ -2665,7 +2662,6 @@ call2 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2) } /* Call function fn with 3 arguments arg1, arg2, arg3. */ -/* ARGSUSED */ Lisp_Object call3 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3) { @@ -2673,7 +2669,6 @@ call3 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3) } /* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */ -/* ARGSUSED */ Lisp_Object call4 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4) @@ -2682,7 +2677,6 @@ call4 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, } /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */ -/* ARGSUSED */ Lisp_Object call5 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5) @@ -2691,7 +2685,6 @@ call5 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, } /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */ -/* ARGSUSED */ Lisp_Object call6 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6) @@ -2700,7 +2693,6 @@ call6 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, } /* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */ -/* ARGSUSED */ Lisp_Object call7 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6, Lisp_Object arg7) @@ -2710,7 +2702,6 @@ call7 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, /* Call function fn with 8 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8. */ -/* ARGSUSED */ Lisp_Object call8 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6, Lisp_Object arg7, diff --git a/src/fileio.c b/src/fileio.c index cbc0c89cf3e..5337ea5c800 100644 --- a/src/fileio.c +++ b/src/fileio.c @@ -134,60 +134,45 @@ static dev_t timestamp_file_system; is added here. */ static Lisp_Object Vwrite_region_annotation_buffers; +static Lisp_Object file_name_directory (Lisp_Object); static bool a_write (int, Lisp_Object, ptrdiff_t, ptrdiff_t, Lisp_Object *, struct coding_system *); static bool e_write (int, Lisp_Object, ptrdiff_t, ptrdiff_t, struct coding_system *); -/* Return true if FILENAME exists, otherwise return false and set errno. */ - -static bool -check_existing (const char *filename) -{ - return faccessat (AT_FDCWD, filename, F_OK, AT_EACCESS) == 0; -} - -/* Return true if file FILENAME exists and can be executed. */ +/* Test whether FILE is accessible for AMODE. + Return true if successful, false (setting errno) otherwise. */ bool -check_executable (char *filename) -{ - return faccessat (AT_FDCWD, filename, X_OK, AT_EACCESS) == 0; -} - -/* Return true if file FILENAME exists and can be accessed - according to AMODE, which should include W_OK. - On failure, return false and set errno. */ - -static bool -check_writable (const char *filename, int amode) +file_access_p (char const *file, int amode) { #ifdef MSDOS - /* FIXME: an faccessat implementation should be added to the - DOS/Windows ports and this #ifdef branch should be removed. */ - struct stat st; - if (stat (filename, &st) < 0) - return 0; - errno = EPERM; - return (st.st_mode & S_IWRITE || S_ISDIR (st.st_mode)); -#else /* not MSDOS */ - bool res = faccessat (AT_FDCWD, filename, amode, AT_EACCESS) == 0; -#ifdef CYGWIN - /* faccessat may have returned failure because Cygwin couldn't - determine the file's UID or GID; if so, we return success. */ - if (!res) + if (amode & W_OK) { - int faccessat_errno = errno; + /* FIXME: The MS-DOS faccessat implementation should handle this. */ struct stat st; - if (stat (filename, &st) < 0) - return 0; - res = (st.st_uid == -1 || st.st_gid == -1); - errno = faccessat_errno; - } -#endif /* CYGWIN */ - return res; -#endif /* not MSDOS */ + if (stat (file, &st) != 0) + return false; + errno = EPERM; + return st.st_mode & S_IWRITE || S_ISDIR (st.st_mode); + } +#endif + + if (faccessat (AT_FDCWD, file, amode, AT_EACCESS) == 0) + return true; + +#ifdef CYGWIN + /* Return success if faccessat failed because Cygwin couldn't + determine the file's UID or GID. */ + int err = errno; + struct stat st; + if (stat (file, &st) == 0 && (st.st_uid == -1 || st.st_gid == -1)) + return true; + errno = err; +#endif + + return false; } /* Signal a file-access failure. STRING describes the failure, @@ -250,6 +235,44 @@ report_file_notify_error (const char *string, Lisp_Object name) } #endif +/* ACTION failed for FILE with errno ERR. Signal an error if ERR + means the file's metadata could not be retrieved even though it may + exist, otherwise return nil. */ + +static Lisp_Object +file_metadata_errno (char const *action, Lisp_Object file, int err) +{ + if (err == ENOENT || err == ENOTDIR || err == 0) + return Qnil; + report_file_errno (action, file, err); +} + +Lisp_Object +file_attribute_errno (Lisp_Object file, int err) +{ + return file_metadata_errno ("Getting attributes", file, err); +} + +/* In theory, EACCES errors for predicates like file-readable-p should + be checked further because they may be problems with an ancestor + directory instead of with the file itself, which means that we + don't have reliable info about the requested file. In practice, + though, such errors are common enough that signaling them can be + annoying even if the errors are real (e.g., Bug#37445). So return + nil for EACCES unless compiling with -DPICKY_EACCES, which is off + by default. */ +#ifndef PICKY_EACCES +enum { PICKY_EACCES = false }; +#endif + +Lisp_Object +file_test_errno (Lisp_Object file, int err) +{ + if (!PICKY_EACCES && err == EACCES) + return Qnil; + return file_metadata_errno ("Testing file", file, err); +} + void close_file_unwind (int fd) { @@ -356,6 +379,15 @@ Given a Unix syntax file name, returns a string ending in slash. */) return STRINGP (handled_name) ? handled_name : Qnil; } + return file_name_directory (filename); +} + +/* Return the directory component of FILENAME, or nil if FILENAME does + not contain a directory component. */ + +static Lisp_Object +file_name_directory (Lisp_Object filename) +{ char *beg = SSDATA (filename); char const *p = beg + SBYTES (filename); @@ -2369,41 +2401,48 @@ internal_delete_file (Lisp_Object filename) return NILP (tem); } -/* Filesystems are case-sensitive on all supported systems except - MS-Windows, MS-DOS, Cygwin, and Mac OS X. They are always - case-insensitive on the first two, but they may or may not be - case-insensitive on Cygwin and OS X. The following function - attempts to provide a runtime test on those two systems. If the - test is not conclusive, we assume case-insensitivity on Cygwin and - case-sensitivity on Mac OS X. - - FIXME: Mounted filesystems on Posix hosts, like Samba shares or - NFS-mounted Windows volumes, might be case-insensitive. Can we - detect this? */ +/* Return -1 if FILE is a case-insensitive file name, 0 if not, + and a positive errno value if the result cannot be determined. */ -static bool -file_name_case_insensitive_p (const char *filename) +static int +file_name_case_insensitive_err (Lisp_Object file) { - /* Use pathconf with _PC_CASE_INSENSITIVE or _PC_CASE_SENSITIVE if - those flags are available. As of this writing (2017-05-20), + /* Filesystems are case-sensitive on all supported systems except + MS-Windows, MS-DOS, Cygwin, and macOS. They are always + case-insensitive on the first two, but they may or may not be + case-insensitive on Cygwin and macOS so do a runtime test on + those two systems. If the test is not conclusive, assume + case-insensitivity on Cygwin and case-sensitivity on macOS. + + FIXME: Mounted filesystems on Posix hosts, like Samba shares or + NFS-mounted Windows volumes, might be case-insensitive. Can we + detect this? + + Use pathconf with _PC_CASE_INSENSITIVE or _PC_CASE_SENSITIVE if + those flags are available. As of this writing (2019-09-15), Cygwin is the only platform known to support the former (starting with Cygwin-2.6.1), and macOS is the only platform known to support the latter. */ -#ifdef _PC_CASE_INSENSITIVE - int res = pathconf (filename, _PC_CASE_INSENSITIVE); +#if defined _PC_CASE_INSENSITIVE || defined _PC_CASE_SENSITIVE + char *filename = SSDATA (ENCODE_FILE (file)); +# ifdef _PC_CASE_INSENSITIVE + long int res = pathconf (filename, _PC_CASE_INSENSITIVE); if (res >= 0) - return res > 0; -#elif defined _PC_CASE_SENSITIVE - int res = pathconf (filename, _PC_CASE_SENSITIVE); + return - (res > 0); +# else + long int res = pathconf (filename, _PC_CASE_SENSITIVE); if (res >= 0) - return res == 0; + return - (res == 0); +# endif + if (errno != EINVAL) + return errno; #endif #if defined CYGWIN || defined DOS_NT - return true; + return -1; #else - return false; + return 0; #endif } @@ -2426,21 +2465,22 @@ The arg must be a string. */) /* If the file doesn't exist, move up the filesystem tree until we reach an existing directory or the root. */ - if (NILP (Ffile_exists_p (filename))) + while (true) { - filename = Ffile_name_directory (filename); - while (NILP (Ffile_exists_p (filename))) + int err = file_name_case_insensitive_err (filename); + switch (err) { - Lisp_Object newname = expand_and_dir_to_file (filename); - /* Avoid infinite loop if the root is reported as non-existing - (impossible?). */ - if (!NILP (Fstring_equal (newname, filename))) - break; - filename = newname; + case -1: return Qt; + default: return file_test_errno (filename, err); + case ENOENT: case ENOTDIR: break; } + Lisp_Object parent = file_name_directory (filename); + /* Avoid infinite loop if the root is reported as non-existing + (impossible?). */ + if (!NILP (Fstring_equal (parent, filename))) + return Qnil; + filename = parent; } - filename = ENCODE_FILE (filename); - return file_name_case_insensitive_p (SSDATA (filename)) ? Qt : Qnil; } DEFUN ("rename-file", Frename_file, Srename_file, 2, 3, @@ -2546,7 +2586,7 @@ This is what happens in interactive use with M-x. */) { Lisp_Object symlink_target = (S_ISLNK (file_st.st_mode) - ? emacs_readlinkat (AT_FDCWD, SSDATA (encoded_file)) + ? check_emacs_readlinkat (AT_FDCWD, file, SSDATA (encoded_file)) : Qnil); if (!NILP (symlink_target)) Fmake_symbolic_link (symlink_target, newname, ok_if_already_exists); @@ -2694,32 +2734,48 @@ file_name_absolute_p (char const *filename) || user_homedir (&filename[1])))); } -DEFUN ("file-exists-p", Ffile_exists_p, Sfile_exists_p, 1, 1, 0, - doc: /* Return t if file FILENAME exists (whether or not you can read it). -See also `file-readable-p' and `file-attributes'. -This returns nil for a symlink to a nonexistent file. -Use `file-symlink-p' to test for such links. */) - (Lisp_Object filename) -{ - Lisp_Object absname; - Lisp_Object handler; +/* Return t if FILE exists and is accessible via OPERATION and AMODE, + nil (setting errno) if not. Signal an error if the result cannot + be determined. */ - CHECK_STRING (filename); - absname = Fexpand_file_name (filename, Qnil); - - /* If the file name has special constructs in it, - call the corresponding file name handler. */ - handler = Ffind_file_name_handler (absname, Qfile_exists_p); +static Lisp_Object +check_file_access (Lisp_Object file, Lisp_Object operation, int amode) +{ + file = Fexpand_file_name (file, Qnil); + Lisp_Object handler = Ffind_file_name_handler (file, operation); if (!NILP (handler)) { - Lisp_Object result = call2 (handler, Qfile_exists_p, absname); + Lisp_Object ok = call2 (handler, operation, file); + /* This errno value is bogus. Any caller that depends on errno + should be rethought anyway, to avoid a race between testing a + handled file's accessibility and using the file. */ errno = 0; - return result; + return ok; } - absname = ENCODE_FILE (absname); + char *encoded_file = SSDATA (ENCODE_FILE (file)); + bool ok = file_access_p (encoded_file, amode); + if (ok) + return Qt; + int err = errno; + if (err == EROFS || err == ETXTBSY + || (PICKY_EACCES && err == EACCES && amode != F_OK + && file_access_p (encoded_file, F_OK))) + { + errno = err; + return Qnil; + } + return file_test_errno (file, err); +} - return check_existing (SSDATA (absname)) ? Qt : Qnil; +DEFUN ("file-exists-p", Ffile_exists_p, Sfile_exists_p, 1, 1, 0, + doc: /* Return t if file FILENAME exists (whether or not you can read it). +See also `file-readable-p' and `file-attributes'. +This returns nil for a symlink to a nonexistent file. +Use `file-symlink-p' to test for such links. */) + (Lisp_Object filename) +{ + return check_file_access (filename, Qfile_exists_p, F_OK); } DEFUN ("file-executable-p", Ffile_executable_p, Sfile_executable_p, 1, 1, 0, @@ -2729,21 +2785,7 @@ For a directory, this means you can access files in that directory. purpose, though.) */) (Lisp_Object filename) { - Lisp_Object absname; - Lisp_Object handler; - - CHECK_STRING (filename); - absname = Fexpand_file_name (filename, Qnil); - - /* If the file name has special constructs in it, - call the corresponding file name handler. */ - handler = Ffind_file_name_handler (absname, Qfile_executable_p); - if (!NILP (handler)) - return call2 (handler, Qfile_executable_p, absname); - - absname = ENCODE_FILE (absname); - - return (check_executable (SSDATA (absname)) ? Qt : Qnil); + return check_file_access (filename, Qfile_executable_p, X_OK); } DEFUN ("file-readable-p", Ffile_readable_p, Sfile_readable_p, 1, 1, 0, @@ -2751,21 +2793,7 @@ DEFUN ("file-readable-p", Ffile_readable_p, Sfile_readable_p, 1, 1, 0, See also `file-exists-p' and `file-attributes'. */) (Lisp_Object filename) { - Lisp_Object absname; - Lisp_Object handler; - - CHECK_STRING (filename); - absname = Fexpand_file_name (filename, Qnil); - - /* If the file name has special constructs in it, - call the corresponding file name handler. */ - handler = Ffind_file_name_handler (absname, Qfile_readable_p); - if (!NILP (handler)) - return call2 (handler, Qfile_readable_p, absname); - - absname = ENCODE_FILE (absname); - return (faccessat (AT_FDCWD, SSDATA (absname), R_OK, AT_EACCESS) == 0 - ? Qt : Qnil); + return check_file_access (filename, Qfile_readable_p, R_OK); } DEFUN ("file-writable-p", Ffile_writable_p, Sfile_writable_p, 1, 1, 0, @@ -2775,7 +2803,6 @@ DEFUN ("file-writable-p", Ffile_writable_p, Sfile_writable_p, 1, 1, 0, Lisp_Object absname, dir, encoded; Lisp_Object handler; - CHECK_STRING (filename); absname = Fexpand_file_name (filename, Qnil); /* If the file name has special constructs in it, @@ -2785,25 +2812,34 @@ DEFUN ("file-writable-p", Ffile_writable_p, Sfile_writable_p, 1, 1, 0, return call2 (handler, Qfile_writable_p, absname); encoded = ENCODE_FILE (absname); - if (check_writable (SSDATA (encoded), W_OK)) + if (file_access_p (SSDATA (encoded), W_OK)) return Qt; if (errno != ENOENT) return Qnil; - dir = Ffile_name_directory (absname); + dir = file_name_directory (absname); eassert (!NILP (dir)); #ifdef MSDOS dir = Fdirectory_file_name (dir); #endif /* MSDOS */ - dir = ENCODE_FILE (dir); + encoded = ENCODE_FILE (dir); #ifdef WINDOWSNT /* The read-only attribute of the parent directory doesn't affect whether a file or directory can be created within it. Some day we should check ACLs though, which do affect this. */ - return file_directory_p (dir) ? Qt : Qnil; + return file_directory_p (encoded) ? Qt : Qnil; #else - return check_writable (SSDATA (dir), W_OK | X_OK) ? Qt : Qnil; + if (file_access_p (SSDATA (encoded), W_OK | X_OK)) + return Qt; + int err = errno; + if (err == EROFS + || (err == EACCES && file_access_p (SSDATA (encoded), F_OK))) + { + errno = err; + return Qnil; + } + return file_test_errno (absname, err); #endif } @@ -2835,8 +2871,8 @@ If there is no error, returns nil. */) } /* Relative to directory FD, return the symbolic link value of FILENAME. - On failure, return nil. */ -Lisp_Object + On failure, return nil (setting errno). */ +static Lisp_Object emacs_readlinkat (int fd, char const *filename) { static struct allocator const emacs_norealloc_allocator = @@ -2855,6 +2891,27 @@ emacs_readlinkat (int fd, char const *filename) return val; } +/* Relative to directory FD, return the symbolic link value of FILE. + If FILE is not a symbolic link, return nil (setting errno). + Signal an error if the result cannot be determined. */ +Lisp_Object +check_emacs_readlinkat (int fd, Lisp_Object file, char const *encoded_file) +{ + Lisp_Object val = emacs_readlinkat (fd, encoded_file); + if (NILP (val)) + { + if (errno == EINVAL) + return val; +#ifdef CYGWIN + /* Work around Cygwin bugs. */ + if (errno == EIO || errno == EACCES) + return val; +#endif + return file_metadata_errno ("Reading symbolic link", file, errno); + } + return val; +} + DEFUN ("file-symlink-p", Ffile_symlink_p, Sfile_symlink_p, 1, 1, 0, doc: /* Return non-nil if file FILENAME is the name of a symbolic link. The value is the link target, as a string. @@ -2874,9 +2931,8 @@ This function does not check whether the link target exists. */) if (!NILP (handler)) return call2 (handler, Qfile_symlink_p, filename); - filename = ENCODE_FILE (filename); - - return emacs_readlinkat (AT_FDCWD, SSDATA (filename)); + return check_emacs_readlinkat (AT_FDCWD, filename, + SSDATA (ENCODE_FILE (filename))); } DEFUN ("file-directory-p", Ffile_directory_p, Sfile_directory_p, 1, 1, 0, @@ -2893,9 +2949,9 @@ See `file-symlink-p' to distinguish symlinks. */) if (!NILP (handler)) return call2 (handler, Qfile_directory_p, absname); - absname = ENCODE_FILE (absname); - - return file_directory_p (absname) ? Qt : Qnil; + if (file_directory_p (absname)) + return Qt; + return file_test_errno (absname, errno); } /* Return true if FILE is a directory or a symlink to a directory. @@ -2905,7 +2961,10 @@ file_directory_p (Lisp_Object file) { #ifdef DOS_NT /* This is cheaper than 'stat'. */ - return faccessat (AT_FDCWD, SSDATA (file), D_OK, AT_EACCESS) == 0; + bool retval = faccessat (AT_FDCWD, SSDATA (file), D_OK, AT_EACCESS) == 0; + if (!retval && errno == EACCES) + errno = ENOTDIR; /* like the non-DOS_NT branch below does */ + return retval; #else # ifdef O_PATH /* Use O_PATH if available, as it avoids races and EOVERFLOW issues. */ @@ -2920,7 +2979,7 @@ file_directory_p (Lisp_Object file) /* O_PATH is defined but evidently this Linux kernel predates 2.6.39. Fall back on generic POSIX code. */ # endif - /* Use file_accessible_directory, as it avoids stat EOVERFLOW + /* Use file_accessible_directory_p, as it avoids stat EOVERFLOW problems and could be cheaper. However, if it fails because FILE is inaccessible, fall back on stat; if the latter fails with EOVERFLOW then FILE must have been a directory unless a race @@ -2976,8 +3035,13 @@ really is a readable and searchable directory. */) return r; } - absname = ENCODE_FILE (absname); - return file_accessible_directory_p (absname) ? Qt : Qnil; + Lisp_Object encoded_absname = ENCODE_FILE (absname); + if (file_accessible_directory_p (encoded_absname)) + return Qt; + int err = errno; + if (err == EACCES && file_access_p (SSDATA (encoded_absname), F_OK)) + return Qnil; + return file_test_errno (absname, err); } /* If FILE is a searchable directory or a symlink to a @@ -3029,7 +3093,7 @@ file_accessible_directory_p (Lisp_Object file) dir = buf; } - ok = check_existing (dir); + ok = file_access_p (dir, F_OK); saved_errno = errno; SAFE_FREE (); errno = saved_errno; @@ -3053,27 +3117,21 @@ See `file-symlink-p' to distinguish symlinks. */) if (!NILP (handler)) return call2 (handler, Qfile_regular_p, absname); - absname = ENCODE_FILE (absname); - #ifdef WINDOWSNT - { - int result; - Lisp_Object tem = Vw32_get_true_file_attributes; + /* Tell stat to use expensive method to get accurate info. */ + Lisp_Object true_attributes = Vw32_get_true_file_attributes; + Vw32_get_true_file_attributes = Qt; +#endif - /* Tell stat to use expensive method to get accurate info. */ - Vw32_get_true_file_attributes = Qt; - result = stat (SSDATA (absname), &st); - Vw32_get_true_file_attributes = tem; + int stat_result = stat (SSDATA (absname), &st); - if (result < 0) - return Qnil; - return S_ISREG (st.st_mode) ? Qt : Qnil; - } -#else - if (stat (SSDATA (absname), &st) < 0) - return Qnil; - return S_ISREG (st.st_mode) ? Qt : Qnil; +#ifdef WINDOWSNT + Vw32_get_true_file_attributes = true_attributes; #endif + + if (stat_result == 0) + return S_ISREG (st.st_mode) ? Qt : Qnil; + return file_test_errno (absname, errno); } DEFUN ("file-selinux-context", Ffile_selinux_context, @@ -3083,7 +3141,7 @@ The return value is a list (USER ROLE TYPE RANGE), where the list elements are strings naming the user, role, type, and range of the file's SELinux security context. -Return (nil nil nil nil) if the file is nonexistent or inaccessible, +Return (nil nil nil nil) if the file is nonexistent, or if SELinux is disabled, or if Emacs lacks SELinux support. */) (Lisp_Object filename) { @@ -3097,13 +3155,11 @@ or if SELinux is disabled, or if Emacs lacks SELinux support. */) if (!NILP (handler)) return call2 (handler, Qfile_selinux_context, absname); - absname = ENCODE_FILE (absname); - #if HAVE_LIBSELINUX if (is_selinux_enabled ()) { security_context_t con; - int conlength = lgetfilecon (SSDATA (absname), &con); + int conlength = lgetfilecon (SSDATA (ENCODE_FILE (absname)), &con); if (conlength > 0) { context_t context = context_new (con); @@ -3118,6 +3174,9 @@ or if SELinux is disabled, or if Emacs lacks SELinux support. */) context_free (context); freecon (con); } + else if (! (errno == ENOENT || errno == ENOTDIR || errno == ENODATA + || errno == ENOTSUP)) + report_file_error ("getting SELinux context", absname); } #endif @@ -3213,8 +3272,7 @@ DEFUN ("file-acl", Ffile_acl, Sfile_acl, 1, 1, 0, doc: /* Return ACL entries of file named FILENAME. The entries are returned in a format suitable for use in `set-file-acl' but is otherwise undocumented and subject to change. -Return nil if file does not exist or is not accessible, or if Emacs -was unable to determine the ACL entries. */) +Return nil if file does not exist. */) (Lisp_Object filename) { Lisp_Object acl_string = Qnil; @@ -3229,20 +3287,22 @@ was unable to determine the ACL entries. */) return call2 (handler, Qfile_acl, absname); # ifdef HAVE_ACL_SET_FILE - absname = ENCODE_FILE (absname); - # ifndef HAVE_ACL_TYPE_EXTENDED acl_type_t ACL_TYPE_EXTENDED = ACL_TYPE_ACCESS; # endif - acl_t acl = acl_get_file (SSDATA (absname), ACL_TYPE_EXTENDED); + acl_t acl = acl_get_file (SSDATA (ENCODE_FILE (absname)), ACL_TYPE_EXTENDED); if (acl == NULL) - return Qnil; - + { + if (errno == ENOENT || errno == ENOTDIR || errno == ENOTSUP) + return Qnil; + report_file_error ("Getting ACLs", absname); + } char *str = acl_to_text (acl, NULL); if (str == NULL) { + int err = errno; acl_free (acl); - return Qnil; + report_file_errno ("Getting ACLs", absname, err); } acl_string = build_string (str); @@ -3313,7 +3373,7 @@ support. */) DEFUN ("file-modes", Ffile_modes, Sfile_modes, 1, 1, 0, doc: /* Return mode bits of file named FILENAME, as an integer. -Return nil, if file does not exist or is not accessible. */) +Return nil if FILENAME does not exist. */) (Lisp_Object filename) { struct stat st; @@ -3325,11 +3385,8 @@ Return nil, if file does not exist or is not accessible. */) if (!NILP (handler)) return call2 (handler, Qfile_modes, absname); - absname = ENCODE_FILE (absname); - - if (stat (SSDATA (absname), &st) < 0) - return Qnil; - + if (stat (SSDATA (ENCODE_FILE (absname)), &st) != 0) + return file_attribute_errno (absname, errno); return make_fixnum (st.st_mode & 07777); } @@ -3473,14 +3530,27 @@ otherwise, if FILE2 does not exist, the answer is t. */) if (!NILP (handler)) return call3 (handler, Qfile_newer_than_file_p, absname1, absname2); - absname1 = ENCODE_FILE (absname1); - absname2 = ENCODE_FILE (absname2); + int err1; + if (stat (SSDATA (ENCODE_FILE (absname1)), &st1) == 0) + err1 = 0; + else + { + err1 = errno; + if (err1 != EOVERFLOW) + return file_test_errno (absname1, err1); + } - if (stat (SSDATA (absname1), &st1) < 0) - return Qnil; + if (stat (SSDATA (ENCODE_FILE (absname2)), &st2) != 0) + { + file_test_errno (absname2, errno); + return Qt; + } - if (stat (SSDATA (absname2), &st2) < 0) - return Qt; + if (err1) + { + file_test_errno (absname1, err1); + eassume (false); + } return (timespec_cmp (get_stat_mtime (&st2), get_stat_mtime (&st1)) < 0 ? Qt : Qnil); @@ -3612,7 +3682,7 @@ file_offset (Lisp_Object val) static struct timespec time_error_value (int errnum) { - int ns = (errnum == ENOENT || errnum == EACCES || errnum == ENOTDIR + int ns = (errnum == ENOENT || errnum == ENOTDIR ? NONEXISTENT_MODTIME_NSECS : UNKNOWN_MODTIME_NSECS); return make_timespec (0, ns); @@ -5672,13 +5742,13 @@ in `current-time' or an integer flag as returned by `visited-file-modtime'. */) /* The handler can find the file name the same way we did. */ return call2 (handler, Qset_visited_file_modtime, Qnil); - filename = ENCODE_FILE (filename); - - if (stat (SSDATA (filename), &st) >= 0) + if (stat (SSDATA (ENCODE_FILE (filename)), &st) == 0) { current_buffer->modtime = get_stat_mtime (&st); current_buffer->modtime_size = st.st_size; } + else + file_attribute_errno (filename, errno); } return Qnil; @@ -5822,7 +5892,7 @@ A non-nil CURRENT-ONLY argument means save only current buffer. */) if (!NILP (Vrun_hooks)) { Lisp_Object dir; - dir = Ffile_name_directory (listfile); + dir = file_name_directory (listfile); if (NILP (Ffile_directory_p (dir))) internal_condition_case_1 (do_auto_save_make_dir, dir, Qt, @@ -6067,16 +6137,18 @@ effect except for flushing STREAM's data. */) #ifndef DOS_NT -/* Yield a Lisp float as close as possible to BLOCKSIZE * BLOCKS, with - the result negated if NEGATE. */ +/* Yield a Lisp number equal to BLOCKSIZE * BLOCKS, with the result + negated if NEGATE. */ static Lisp_Object blocks_to_bytes (uintmax_t blocksize, uintmax_t blocks, bool negate) { - /* On typical platforms the following code is accurate to 53 bits, - which is close enough. BLOCKSIZE is invariably a power of 2, so - converting it to double does not lose information. */ - double bs = blocksize; - return make_float (negate ? -bs * -blocks : bs * blocks); + intmax_t n; + if (!INT_MULTIPLY_WRAPV (blocksize, blocks, &n)) + return make_int (negate ? -n : n); + Lisp_Object bs = make_uint (blocksize); + if (negate) + bs = CALLN (Fminus, bs); + return CALLN (Ftimes, bs, make_uint (blocks)); } DEFUN ("file-system-info", Ffile_system_info, Sfile_system_info, 1, 1, 0, @@ -6087,22 +6159,22 @@ storage available to a non-superuser. All 3 numbers are in bytes. If the underlying system call fails, value is nil. */) (Lisp_Object filename) { - Lisp_Object encoded = ENCODE_FILE (Fexpand_file_name (filename, Qnil)); + filename = Fexpand_file_name (filename, Qnil); /* If the file name has special constructs in it, call the corresponding file name handler. */ - Lisp_Object handler = Ffind_file_name_handler (encoded, Qfile_system_info); + Lisp_Object handler = Ffind_file_name_handler (filename, Qfile_system_info); if (!NILP (handler)) { - Lisp_Object result = call2 (handler, Qfile_system_info, encoded); + Lisp_Object result = call2 (handler, Qfile_system_info, filename); if (CONSP (result) || NILP (result)) return result; error ("Invalid handler in `file-name-handler-alist'"); } struct fs_usage u; - if (get_fs_usage (SSDATA (encoded), NULL, &u) != 0) - return Qnil; + if (get_fs_usage (SSDATA (ENCODE_FILE (filename)), NULL, &u) != 0) + return errno == ENOSYS ? Qnil : file_attribute_errno (filename, errno); return list3 (blocks_to_bytes (u.fsu_blocksize, u.fsu_blocks, false), blocks_to_bytes (u.fsu_blocksize, u.fsu_bfree, false), blocks_to_bytes (u.fsu_blocksize, u.fsu_bavail, diff --git a/src/filelock.c b/src/filelock.c index 46349a63e4a..ff25d6475de 100644 --- a/src/filelock.c +++ b/src/filelock.c @@ -504,9 +504,9 @@ read_lock_data (char *lfname, char lfinfo[MAX_LFINFO + 1]) } /* Return 0 if nobody owns the lock file LFNAME or the lock is obsolete, - 1 if another process owns it (and set OWNER (if non-null) to info), - 2 if the current process owns it, - or -1 if something is wrong with the locking mechanism. */ + -1 if another process owns it (and set OWNER (if non-null) to info), + -2 if the current process owns it, + or an errno value if something is wrong with the locking mechanism. */ static int current_lock_owner (lock_info_type *owner, char *lfname) @@ -525,23 +525,23 @@ current_lock_owner (lock_info_type *owner, char *lfname) /* If nonexistent lock file, all is well; otherwise, got strange error. */ lfinfolen = read_lock_data (lfname, owner->user); if (lfinfolen < 0) - return errno == ENOENT ? 0 : -1; + return errno == ENOENT ? 0 : errno; if (MAX_LFINFO < lfinfolen) - return -1; + return ENAMETOOLONG; owner->user[lfinfolen] = 0; - /* Parse USER@HOST.PID:BOOT_TIME. If can't parse, return -1. */ + /* Parse USER@HOST.PID:BOOT_TIME. If can't parse, return EINVAL. */ /* The USER is everything before the last @. */ owner->at = at = memrchr (owner->user, '@', lfinfolen); if (!at) - return -1; + return EINVAL; owner->dot = dot = strrchr (at, '.'); if (!dot) - return -1; + return EINVAL; /* The PID is everything from the last '.' to the ':' or equivalent. */ if (! c_isdigit (dot[1])) - return -1; + return EINVAL; errno = 0; pid = strtoimax (dot + 1, &owner->colon, 10); if (errno == ERANGE) @@ -562,20 +562,20 @@ current_lock_owner (lock_info_type *owner, char *lfname) mistakenly transliterate ':' to U+F022 in symlink contents. See <https://bugzilla.redhat.com/show_bug.cgi?id=1384153>. */ if (! (boot[0] == '\200' && boot[1] == '\242')) - return -1; + return EINVAL; boot += 2; FALLTHROUGH; case ':': if (! c_isdigit (boot[0])) - return -1; + return EINVAL; boot_time = strtoimax (boot, &lfinfo_end, 10); break; default: - return -1; + return EINVAL; } if (lfinfo_end != owner->user + lfinfolen) - return -1; + return EINVAL; /* On current host? */ Lisp_Object system_name = Fsystem_name (); @@ -584,22 +584,22 @@ current_lock_owner (lock_info_type *owner, char *lfname) && memcmp (at + 1, SSDATA (system_name), SBYTES (system_name)) == 0) { if (pid == getpid ()) - ret = 2; /* We own it. */ + ret = -2; /* We own it. */ else if (0 < pid && pid <= TYPE_MAXIMUM (pid_t) && (kill (pid, 0) >= 0 || errno == EPERM) && (boot_time == 0 || (boot_time <= TYPE_MAXIMUM (time_t) && within_one_second (boot_time, get_boot_time ())))) - ret = 1; /* An existing process on this machine owns it. */ + ret = -1; /* An existing process on this machine owns it. */ /* The owner process is dead or has a strange pid, so try to zap the lockfile. */ else - return unlink (lfname); + return unlink (lfname) < 0 ? errno : 0; } else { /* If we wanted to support the check for stale locks on remote machines, here's where we'd do it. */ - ret = 1; + ret = -1; } return ret; @@ -608,9 +608,9 @@ current_lock_owner (lock_info_type *owner, char *lfname) /* Lock the lock named LFNAME if possible. Return 0 in that case. - Return positive if some other process owns the lock, and info about + Return negative if some other process owns the lock, and info about that process in CLASHER. - Return -1 if cannot lock for any other reason. */ + Return positive errno value if cannot lock for any other reason. */ static int lock_if_free (lock_info_type *clasher, char *lfname) @@ -618,20 +618,18 @@ lock_if_free (lock_info_type *clasher, char *lfname) int err; while ((err = lock_file_1 (lfname, 0)) == EEXIST) { - switch (current_lock_owner (clasher, lfname)) + err = current_lock_owner (clasher, lfname); + if (err != 0) { - case 2: - return 0; /* We ourselves locked it. */ - case 1: - return 1; /* Someone else has it. */ - case -1: - return -1; /* current_lock_owner returned strange error. */ + if (err < 0) + return -2 - err; /* We locked it, or someone else has it. */ + break; /* current_lock_owner returned strange error. */ } /* We deleted a stale lock; try again to lock the file. */ } - return err ? -1 : 0; + return err; } /* lock_file locks file FN, @@ -697,8 +695,9 @@ lock_file (Lisp_Object fn) /* Create the name of the lock-file for file fn */ MAKE_LOCK_NAME (lfname, encoded_fn); - /* Try to lock the lock. */ - if (0 < lock_if_free (&lock_info, lfname)) + /* Try to lock the lock. FIXME: This ignores errors when + lock_if_free returns a positive errno value. */ + if (lock_if_free (&lock_info, lfname) < 0) { /* Someone else has the lock. Consider breaking it. */ Lisp_Object attack; @@ -725,13 +724,16 @@ unlock_file (Lisp_Object fn) char *lfname; USE_SAFE_ALLOCA; - fn = Fexpand_file_name (fn, Qnil); - fn = ENCODE_FILE (fn); + Lisp_Object filename = Fexpand_file_name (fn, Qnil); + fn = ENCODE_FILE (filename); MAKE_LOCK_NAME (lfname, fn); - if (current_lock_owner (0, lfname) == 2) - unlink (lfname); + int err = current_lock_owner (0, lfname); + if (err == -2 && unlink (lfname) != 0 && errno != ENOENT) + err = errno; + if (0 < err) + report_file_errno ("Unlocking file", filename, err); SAFE_FREE (); } @@ -822,17 +824,17 @@ t if it is locked by you, else a string saying which user has locked it. */) USE_SAFE_ALLOCA; filename = Fexpand_file_name (filename, Qnil); - filename = ENCODE_FILE (filename); - - MAKE_LOCK_NAME (lfname, filename); + Lisp_Object encoded_filename = ENCODE_FILE (filename); + MAKE_LOCK_NAME (lfname, encoded_filename); owner = current_lock_owner (&locker, lfname); - if (owner <= 0) - ret = Qnil; - else if (owner == 2) - ret = Qt; - else - ret = make_string (locker.user, locker.at - locker.user); + switch (owner) + { + case -2: ret = Qt; break; + case -1: ret = make_string (locker.user, locker.at - locker.user); break; + case 0: ret = Qnil; break; + default: report_file_errno ("Testing file lock", filename, owner); + } SAFE_FREE (); return ret; diff --git a/src/fns.c b/src/fns.c index df921e28f3b..f45c729cfaf 100644 --- a/src/fns.c +++ b/src/fns.c @@ -532,14 +532,12 @@ Do NOT use this function to compare file names for equality. */) static Lisp_Object concat (ptrdiff_t nargs, Lisp_Object *args, enum Lisp_Type target_type, bool last_special); -/* ARGSUSED */ Lisp_Object concat2 (Lisp_Object s1, Lisp_Object s2) { return concat (2, ((Lisp_Object []) {s1, s2}), Lisp_String, 0); } -/* ARGSUSED */ Lisp_Object concat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3) { @@ -2577,7 +2575,6 @@ This makes STRING unibyte and may change its length. */) return Qnil; } -/* ARGSUSED */ Lisp_Object nconc2 (Lisp_Object s1, Lisp_Object s2) { diff --git a/src/lisp.h b/src/lisp.h index 024e5edb26e..b081ae1cee8 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3824,9 +3824,10 @@ extern void mark_maybe_objects (Lisp_Object const *, ptrdiff_t); extern void mark_stack (char const *, char const *); extern void flush_stack_call_func (void (*func) (void *arg), void *arg); extern void garbage_collect (void); +extern void maybe_garbage_collect (void); extern const char *pending_malloc_warning; extern Lisp_Object zero_vector; -extern intmax_t consing_until_gc; +extern EMACS_INT consing_until_gc; #ifdef HAVE_PDUMPER extern int number_finalizers_run; #endif @@ -4298,7 +4299,6 @@ extern void syms_of_marker (void); /* Defined in fileio.c. */ -extern bool check_executable (char *); extern char *splice_dir_file (char *, char const *, char const *); extern bool file_name_absolute_p (const char *); extern char const *get_homedir (void); @@ -4309,12 +4309,15 @@ extern Lisp_Object write_region (Lisp_Object, Lisp_Object, Lisp_Object, extern void close_file_unwind (int); extern void fclose_unwind (void *); extern void restore_point_unwind (Lisp_Object); +extern bool file_access_p (char const *, int); extern Lisp_Object get_file_errno_data (const char *, Lisp_Object, int); extern AVOID report_file_errno (const char *, Lisp_Object, int); extern AVOID report_file_error (const char *, Lisp_Object); extern AVOID report_file_notify_error (const char *, Lisp_Object); +extern Lisp_Object file_attribute_errno (Lisp_Object, int); +extern Lisp_Object file_test_errno (Lisp_Object, int); extern bool internal_delete_file (Lisp_Object); -extern Lisp_Object emacs_readlinkat (int, const char *); +extern Lisp_Object check_emacs_readlinkat (int, Lisp_Object, char const *); extern bool file_directory_p (Lisp_Object); extern bool file_accessible_directory_p (Lisp_Object); extern void init_fileio (void); @@ -5056,7 +5059,7 @@ INLINE void maybe_gc (void) { if (consing_until_gc < 0) - garbage_collect (); + maybe_garbage_collect (); } INLINE_HEADER_END diff --git a/src/lread.c b/src/lread.c index 6ae7a0d8ba0..ab0fab47a98 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1346,15 +1346,22 @@ Return t if the file exists and loads successfully. */) if (!load_prefer_newer && is_elc) { result = stat (SSDATA (efound), &s1); + int err = errno; if (result == 0) { SSET (efound, SBYTES (efound) - 1, 0); result = stat (SSDATA (efound), &s2); + err = errno; SSET (efound, SBYTES (efound) - 1, 'c'); + if (result != 0) + found = Fsubstring (found, make_fixnum (0), + make_fixnum (-1)); } - - if (result == 0 - && timespec_cmp (get_stat_mtime (&s1), get_stat_mtime (&s2)) < 0) + if (result != 0) + file_test_errno (found, err); + else if (timespec_cmp (get_stat_mtime (&s1), + get_stat_mtime (&s2)) + < 0) { /* Make the progress messages mention that source is newer. */ newer = 1; @@ -1748,16 +1755,20 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, { if (file_directory_p (encoded_fn)) last_errno = EISDIR; - else + else if (errno == ENOENT || errno == ENOTDIR) fd = 1; + else + last_errno = errno; } + else if (! (errno == ENOENT || errno == ENOTDIR)) + last_errno = errno; } else { fd = emacs_open (pfn, O_RDONLY, 0); if (fd < 0) { - if (errno != ENOENT) + if (! (errno == ENOENT || errno == ENOTDIR)) last_errno = errno; } else diff --git a/src/print.c b/src/print.c index 7c3da68fc98..7e5aed82877 100644 --- a/src/print.c +++ b/src/print.c @@ -81,7 +81,7 @@ static ptrdiff_t print_buffer_pos_byte; -N the object will be printed several times and will take number N. N the object has been printed so we can refer to it as #N#. print_number_index holds the largest N already used. - N has to be striclty larger than 0 since we need to distinguish -N. */ + N has to be strictly larger than 0 since we need to distinguish -N. */ static ptrdiff_t print_number_index; static void print_interval (INTERVAL interval, Lisp_Object printcharfun); @@ -1120,8 +1120,8 @@ print (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) Vprint_number_table = Qnil; } - /* Construct Vprint_number_table for print-gensym and print-circle. */ - if (!NILP (Vprint_gensym) || !NILP (Vprint_circle)) + /* Construct Vprint_number_table for print-circle. */ + if (!NILP (Vprint_circle)) { /* Construct Vprint_number_table. This increments print_number_index for the objects added. */ @@ -1149,7 +1149,11 @@ print (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) } #define PRINT_CIRCLE_CANDIDATE_P(obj) \ - (STRINGP (obj) || CONSP (obj) \ + ((STRINGP (obj) \ + && (string_intervals (obj) \ + || print_depth > 1 \ + || !NILP (Vprint_continuous_numbering))) \ + || CONSP (obj) \ || (VECTORLIKEP (obj) \ && (VECTORP (obj) || COMPILEDP (obj) \ || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) \ @@ -1159,13 +1163,14 @@ print (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) && SYMBOLP (obj) \ && !SYMBOL_INTERNED_P (obj))) -/* Construct Vprint_number_table according to the structure of OBJ. - OBJ itself and all its elements will be added to Vprint_number_table - recursively if it is a list, vector, compiled function, char-table, - string (its text properties will be traced), or a symbol that has - no obarray (this is for the print-gensym feature). - The status fields of Vprint_number_table mean whether each object appears - more than once in OBJ: Qnil at the first time, and Qt after that. */ +/* Construct Vprint_number_table for the print-circle feature + according to the structure of OBJ. OBJ itself and all its elements + will be added to Vprint_number_table recursively if it is a list, + vector, compiled function, char-table, string (its text properties + will be traced), or a symbol that has no obarray (this is for the + print-gensym feature). The status fields of Vprint_number_table + mean whether each object appears more than once in OBJ: Qnil at the + first time, and Qt after that. */ static void print_preprocess (Lisp_Object obj) { @@ -1174,20 +1179,7 @@ print_preprocess (Lisp_Object obj) int loop_count = 0; Lisp_Object halftail; - /* Avoid infinite recursion for circular nested structure - in the case where Vprint_circle is nil. */ - if (NILP (Vprint_circle)) - { - /* Give up if we go so deep that print_object will get an error. */ - /* See similar code in print_object. */ - if (print_depth >= PRINT_CIRCLE) - error ("Apparently circular structure being printed"); - - for (i = 0; i < print_depth; i++) - if (EQ (obj, being_printed[i])) - return; - being_printed[print_depth] = obj; - } + eassert (!NILP (Vprint_circle)); print_depth++; halftail = obj; @@ -1198,33 +1190,28 @@ print_preprocess (Lisp_Object obj) if (!HASH_TABLE_P (Vprint_number_table)) Vprint_number_table = CALLN (Fmake_hash_table, QCtest, Qeq); - /* In case print-circle is nil and print-gensym is t, - add OBJ to Vprint_number_table only when OBJ is a symbol. */ - if (! NILP (Vprint_circle) || SYMBOLP (obj)) - { - Lisp_Object num = Fgethash (obj, Vprint_number_table, Qnil); - if (!NILP (num) - /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym, - always print the gensym with a number. This is a special for - the lisp function byte-compile-output-docform. */ - || (!NILP (Vprint_continuous_numbering) - && SYMBOLP (obj) - && !SYMBOL_INTERNED_P (obj))) - { /* OBJ appears more than once. Let's remember that. */ - if (!FIXNUMP (num)) - { - print_number_index++; - /* Negative number indicates it hasn't been printed yet. */ - Fputhash (obj, make_fixnum (- print_number_index), - Vprint_number_table); - } - print_depth--; - return; + Lisp_Object num = Fgethash (obj, Vprint_number_table, Qnil); + if (!NILP (num) + /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym, + always print the gensym with a number. This is a special for + the lisp function byte-compile-output-docform. */ + || (!NILP (Vprint_continuous_numbering) + && SYMBOLP (obj) + && !SYMBOL_INTERNED_P (obj))) + { /* OBJ appears more than once. Let's remember that. */ + if (!FIXNUMP (num)) + { + print_number_index++; + /* Negative number indicates it hasn't been printed yet. */ + Fputhash (obj, make_fixnum (- print_number_index), + Vprint_number_table); } - else - /* OBJ is not yet recorded. Let's add to the table. */ - Fputhash (obj, Qt, Vprint_number_table); + print_depth--; + return; } + else + /* OBJ is not yet recorded. Let's add to the table. */ + Fputhash (obj, Qt, Vprint_number_table); switch (XTYPE (obj)) { @@ -1271,11 +1258,15 @@ print_preprocess (Lisp_Object obj) DEFUN ("print--preprocess", Fprint_preprocess, Sprint_preprocess, 1, 1, 0, doc: /* Extract sharing info from OBJECT needed to print it. -Fills `print-number-table'. */) - (Lisp_Object object) +Fills `print-number-table' if `print-circle' is non-nil. Does nothing +if `print-circle' is nil. */) + (Lisp_Object object) { - print_number_index = 0; - print_preprocess (object); + if (!NILP (Vprint_circle)) + { + print_number_index = 0; + print_preprocess (object); + } return Qnil; } @@ -1860,7 +1851,6 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) /* Simple but incomplete way. */ int i; - /* See similar code in print_preprocess. */ if (print_depth >= PRINT_CIRCLE) error ("Apparently circular structure being printed"); diff --git a/src/profiler.c b/src/profiler.c index 6943905062c..84583cec765 100644 --- a/src/profiler.c +++ b/src/profiler.c @@ -66,11 +66,11 @@ make_log (void) Qnil, false); struct Lisp_Hash_Table *h = XHASH_TABLE (log); - /* What is special about our hash-tables is that the keys are pre-filled - with the vectors we'll put in them. */ + /* What is special about our hash-tables is that the values are pre-filled + with the vectors we'll use as keys. */ ptrdiff_t i = ASIZE (h->key_and_value) >> 1; while (i > 0) - set_hash_key_slot (h, --i, make_nil_vector (max_stack_depth)); + set_hash_value_slot (h, --i, make_nil_vector (max_stack_depth)); return log; } @@ -132,13 +132,14 @@ static void evict_lower_half (log_t *log) XSET_HASH_TABLE (tmp, log); /* FIXME: Use make_lisp_ptr. */ Fremhash (key, tmp); } + eassert (EQ (Qunbound, HASH_KEY (log, i))); eassert (log->next_free == i); eassert (VECTORP (key)); for (ptrdiff_t j = 0; j < ASIZE (key); j++) ASET (key, j, Qnil); - set_hash_key_slot (log, i, key); + set_hash_value_slot (log, i, key); } } @@ -156,7 +157,8 @@ record_backtrace (log_t *log, EMACS_INT count) ptrdiff_t index = log->next_free; /* Get a "working memory" vector. */ - Lisp_Object backtrace = HASH_KEY (log, index); + Lisp_Object backtrace = HASH_VALUE (log, index); + eassert (EQ (Qunbound, HASH_KEY (log, index))); get_backtrace (backtrace); { /* We basically do a `gethash+puthash' here, except that we have to be diff --git a/src/term.c b/src/term.c index a88d47f9238..5f70c7a3d4f 100644 --- a/src/term.c +++ b/src/term.c @@ -1084,7 +1084,6 @@ int *char_ins_del_vector; #define char_ins_del_cost(f) (&char_ins_del_vector[FRAME_COLS ((f))]) -/* ARGSUSED */ static void calculate_ins_del_char_costs (struct frame *f) { diff --git a/src/w32.c b/src/w32.c index d7a91692c63..88e9aef338f 100644 --- a/src/w32.c +++ b/src/w32.c @@ -4151,13 +4151,36 @@ w32_accessible_directory_p (const char *dirname, ptrdiff_t dirlen) /* In case DIRNAME cannot be expressed in characters from the current ANSI codepage. */ if (_mbspbrk (pat_a, "?")) - dh = INVALID_HANDLE_VALUE; - else - dh = FindFirstFileA (pat_a, &dfd_a); + { + errno = ENOENT; + return 0; + } + dh = FindFirstFileA (pat_a, &dfd_a); } if (dh == INVALID_HANDLE_VALUE) + { + DWORD w32err = GetLastError (); + + switch (w32err) + { + case ERROR_INVALID_NAME: + case ERROR_BAD_PATHNAME: + case ERROR_FILE_NOT_FOUND: + case ERROR_PATH_NOT_FOUND: + case ERROR_NO_MORE_FILES: + case ERROR_BAD_NETPATH: + errno = ENOENT; + break; + case ERROR_NOT_READY: + errno = ENODEV; + break; + default: + errno = EACCES; + break; + } return 0; + } FindClose (dh); return 1; } diff --git a/src/w32fns.c b/src/w32fns.c index d6fd8f53490..34abd026f95 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -10109,8 +10109,8 @@ KEY can use either forward- or back-slashes. To access the default value of KEY (if it is defined), use NAME that is an empty string. -If the the named KEY or its subkey called NAME don't exist, or cannot -be accessed by the current user, the function returns nil. Otherwise, +If the named KEY or its subkey called NAME don't exist, or cannot be +accessed by the current user, the function returns nil. Otherwise, the return value depends on the type of the data stored in Registry: If the data type is REG_NONE, the function returns t. diff --git a/src/w32font.c b/src/w32font.c index 14d49b24d9b..9a334717c12 100644 --- a/src/w32font.c +++ b/src/w32font.c @@ -90,6 +90,8 @@ struct font_callback_data Lisp_Object orig_font_spec; /* The frame the font is being loaded on. */ Lisp_Object frame; + /* Fonts known to support the font spec, or nil if none. */ + Lisp_Object known_fonts; /* The list to add matches to. */ Lisp_Object list; /* Whether to match only opentype fonts. */ @@ -841,6 +843,25 @@ w32font_list_internal (struct frame *f, Lisp_Object font_spec, match_data.opentype_only = opentype_only; if (opentype_only) match_data.pattern.lfOutPrecision = OUT_OUTLINE_PRECIS; + match_data.known_fonts = Qnil; + Lisp_Object vw32_non_USB_fonts = Fsymbol_value (Qw32_non_USB_fonts), val; + if (CONSP (vw32_non_USB_fonts)) + { + Lisp_Object extra; + for (extra = AREF (font_spec, FONT_EXTRA_INDEX); + CONSP (extra); extra = XCDR (extra)) + { + Lisp_Object tem = XCAR (extra); + if (CONSP (tem) + && EQ (XCAR (tem), QCscript) + && SYMBOLP (XCDR (tem)) + && !NILP (val = assq_no_quit (XCDR (tem), vw32_non_USB_fonts))) + { + match_data.known_fonts = XCDR (val); + break; + } + } + } if (match_data.pattern.lfFaceName[0] == '\0') { @@ -890,6 +911,26 @@ w32font_match_internal (struct frame *f, Lisp_Object font_spec, if (opentype_only) match_data.pattern.lfOutPrecision = OUT_OUTLINE_PRECIS; + match_data.known_fonts = Qnil; + Lisp_Object vw32_non_USB_fonts = Fsymbol_value (Qw32_non_USB_fonts), val; + if (CONSP (vw32_non_USB_fonts)) + { + Lisp_Object extra; + for (extra = AREF (font_spec, FONT_EXTRA_INDEX); + CONSP (extra); extra = XCDR (extra)) + { + Lisp_Object tem = XCAR (extra); + if (CONSP (tem) + && EQ (XCAR (tem), QCscript) + && SYMBOLP (XCDR (tem)) + && !NILP (val = assq_no_quit (XCDR (tem), vw32_non_USB_fonts))) + { + match_data.known_fonts = XCDR (val); + break; + } + } + } + /* Prevent quitting while EnumFontFamiliesEx runs and conses the list it will return. That's because get_frame_dc acquires the critical section, so we cannot quit before we release it in @@ -1511,9 +1552,13 @@ add_font_entity_to_list (ENUMLOGFONTEX *logical_font, /* Ensure a match. */ if (!logfonts_match (&logical_font->elfLogFont, &match_data->pattern) - || !font_matches_spec (font_type, physical_font, - match_data->orig_font_spec, backend, - &logical_font->elfLogFont) + || !(font_matches_spec (font_type, physical_font, + match_data->orig_font_spec, backend, + &logical_font->elfLogFont) + || (!NILP (match_data->known_fonts) + && memq_no_quit + (intern_font_name (logical_font->elfLogFont.lfFaceName), + match_data->known_fonts))) || !w32font_coverage_ok (&physical_font->ntmFontSig, match_data->pattern.lfCharSet)) return 1; @@ -2214,8 +2259,9 @@ font_supported_scripts (FONTSIGNATURE * sig) || (subranges[2] & (mask2)) || (subranges[3] & (mask3))) \ supported = Fcons ((sym), supported) - SUBRANGE (0, Qlatin); - /* 1: Latin-1 supplement, 2: Latin Extended A, 3: Latin Extended B. */ + /* 0: ASCII (a.k.a. "Basic Latin"), + 1: Latin-1 supplement, 2: Latin Extended A, 3: Latin Extended B, + 29: Latin Extended Additional. */ /* Most fonts that support Latin will have good coverage of the Extended blocks, so in practice marking them below is not really needed, or useful: if a font claims support for, say, Latin @@ -2224,12 +2270,11 @@ font_supported_scripts (FONTSIGNATURE * sig) fontset to display those few characters. But we mark these subranges here anyway, for the marginal use cases where they might make a difference. */ - SUBRANGE (1, Qlatin); - SUBRANGE (2, Qlatin); - SUBRANGE (3, Qlatin); + MASK_ANY (0x2000000F, 0, 0, 0, Qlatin); SUBRANGE (4, Qphonetic); /* 5: Spacing and tone modifiers, 6: Combining Diacritical Marks. */ - SUBRANGE (7, Qgreek); + /* 7: Greek and Coptic, 30: Greek Extended. */ + MASK_ANY (0x40000080, 0, 0, 0, Qgreek); SUBRANGE (8, Qcoptic); SUBRANGE (9, Qcyrillic); SUBRANGE (10, Qarmenian); @@ -2246,7 +2291,7 @@ font_supported_scripts (FONTSIGNATURE * sig) SUBRANGE (16, Qbengali); SUBRANGE (17, Qgurmukhi); SUBRANGE (18, Qgujarati); - SUBRANGE (19, Qoriya); + SUBRANGE (19, Qoriya); /* a.k.a. "Odia" */ SUBRANGE (20, Qtamil); SUBRANGE (21, Qtelugu); SUBRANGE (22, Qkannada); @@ -2259,8 +2304,7 @@ font_supported_scripts (FONTSIGNATURE * sig) /* 29: Latin Extended, 30: Greek Extended -- covered above. */ /* 31: Supplemental Punctuation -- most probably be masked by Courier New, so fontset customization is needed. */ - SUBRANGE (31, Qsymbol); - /* 32-47: Symbols (defined below). */ + /* 31-47: Symbols (defined below). */ SUBRANGE (48, Qcjk_misc); /* Match either 49: katakana or 50: hiragana for kana. */ MASK_ANY (0, 0x00060000, 0, 0, Qkana); @@ -2286,7 +2330,7 @@ font_supported_scripts (FONTSIGNATURE * sig) SUBRANGE (71, Qsyriac); SUBRANGE (72, Qthaana); SUBRANGE (73, Qsinhala); - SUBRANGE (74, Qmyanmar); + SUBRANGE (74, Qburmese); /* a.k.a. "Myanmar" */ SUBRANGE (75, Qethiopic); SUBRANGE (76, Qcherokee); SUBRANGE (77, Qcanadian_aboriginal); @@ -2329,6 +2373,7 @@ font_supported_scripts (FONTSIGNATURE * sig) SUBRANGE (99, Qhan); SUBRANGE (100, Qsyloti_nagri); SUBRANGE (101, Qlinear_b); + SUBRANGE (101, Qaegean_number); SUBRANGE (102, Qancient_greek_number); SUBRANGE (103, Qugaritic); SUBRANGE (104, Qold_persian); @@ -2338,6 +2383,7 @@ font_supported_scripts (FONTSIGNATURE * sig) SUBRANGE (108, Qkharoshthi); SUBRANGE (109, Qtai_xuan_jing_symbol); SUBRANGE (110, Qcuneiform); + SUBRANGE (111, Qcuneiform_numbers_and_punctuation); SUBRANGE (111, Qcounting_rod_numeral); SUBRANGE (112, Qsundanese); SUBRANGE (113, Qlepcha); @@ -2357,9 +2403,52 @@ font_supported_scripts (FONTSIGNATURE * sig) /* There isn't really a main symbol range, so include symbol if any relevant range is set. */ - MASK_ANY (0x8000000, 0x0000FFFF, 0, 0, Qsymbol); - - /* Missing: Tai Viet (U+AA80-U+AADF). */ + MASK_ANY (0x80000000, 0x0000FFFF, 0, 0, Qsymbol); + + /* Missing: + Tai Viet + Old Permic + Palmyrene + Nabatean + Manichean + Hanifi Rohingya + Sogdian + Elymaic + Mahajani + Khojki + Khudawadi + Grantha + Newa + Tirhuta + Siddham + Modi + Takri + Dogra + Warang Citi + Nandinagari + Zanabazar Square + Soyombo + Pau Cin Hau + Bhaiksuki + Marchen + Masaram Gondi + Makasar + Egyptian + Mro + Bassa-Vah + Pahawh Hmong + Medefaidrin + Tangut + Tangut Components + Nushu + Duployan Shorthand + Ancient Greek Musical Notation + Nyiakeng Puachue Hmong + Wancho + Mende Kikakui + Adlam + Indic Siyaq Number + Ottoman Siyaq Number. */ #undef SUBRANGE #undef MASK_ANY @@ -2698,7 +2787,7 @@ syms_of_w32font (void) DEFSYM (Qthai, "thai"); DEFSYM (Qlao, "lao"); DEFSYM (Qtibetan, "tibetan"); - DEFSYM (Qmyanmar, "myanmar"); + DEFSYM (Qburmese, "burmese"); DEFSYM (Qgeorgian, "georgian"); DEFSYM (Qhangul, "hangul"); DEFSYM (Qethiopic, "ethiopic"); @@ -2737,6 +2826,8 @@ syms_of_w32font (void) DEFSYM (Qbuginese, "buginese"); DEFSYM (Qbuhid, "buhid"); DEFSYM (Qcuneiform, "cuneiform"); + DEFSYM (Qcuneiform_numbers_and_punctuation, + "cuneiform-numbers-and-punctuation"); DEFSYM (Qcypriot, "cypriot"); DEFSYM (Qdeseret, "deseret"); DEFSYM (Qglagolitic, "glagolitic"); @@ -2745,6 +2836,7 @@ syms_of_w32font (void) DEFSYM (Qkharoshthi, "kharoshthi"); DEFSYM (Qlimbu, "limbu"); DEFSYM (Qlinear_b, "linear_b"); + DEFSYM (Qaegean_number, "aegean-number"); DEFSYM (Qold_italic, "old_italic"); DEFSYM (Qold_persian, "old_persian"); DEFSYM (Qosmanya, "osmanya"); @@ -2818,6 +2910,7 @@ versions of Windows) characters. */); DEFSYM (Qw32_charset_vietnamese, "w32-charset-vietnamese"); DEFSYM (Qw32_charset_thai, "w32-charset-thai"); DEFSYM (Qw32_charset_mac, "w32-charset-mac"); + DEFSYM (Qw32_non_USB_fonts, "w32-non-USB-fonts"); defsubr (&Sx_select_font); diff --git a/src/xdisp.c b/src/xdisp.c index 94f969f37cf..6626fbcf63e 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -12907,7 +12907,8 @@ tool_bar_height (struct frame *f, int *n_rows, bool pixelwise) temp_row->reversed_p = false; it.first_visible_x = 0; it.last_visible_x = WINDOW_PIXEL_WIDTH (w); - reseat_to_string (&it, NULL, f->desired_tool_bar_string, 0, 0, 0, -1); + reseat_to_string (&it, NULL, f->desired_tool_bar_string, + 0, 0, 0, STRING_MULTIBYTE (f->desired_tool_bar_string)); it.paragraph_embedding = L2R; while (!ITERATOR_AT_END_P (&it)) @@ -12994,7 +12995,8 @@ redisplay_tool_bar (struct frame *f) /* Build a string that represents the contents of the tool-bar. */ build_desired_tool_bar_string (f); - reseat_to_string (&it, NULL, f->desired_tool_bar_string, 0, 0, 0, -1); + reseat_to_string (&it, NULL, f->desired_tool_bar_string, + 0, 0, 0, STRING_MULTIBYTE (f->desired_tool_bar_string)); /* FIXME: This should be controlled by a user option. But it doesn't make sense to have an R2L tool bar if the menu bar cannot be drawn also R2L, and making the menu bar R2L is tricky due @@ -23531,7 +23533,7 @@ display_menu_bar (struct window *w) /* Display the item, pad with one space. */ if (it.current_x < it.last_visible_x) display_string (NULL, string, Qnil, 0, 0, &it, - SCHARS (string) + 1, 0, 0, -1); + SCHARS (string) + 1, 0, 0, STRING_MULTIBYTE (string)); } /* Fill out the line with spaces. */ diff --git a/src/xwidget.c b/src/xwidget.c index 121510ebac0..ecb37936293 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -31,14 +31,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <webkit2/webkit2.h> #include <JavaScriptCore/JavaScript.h> -/* Suppress GCC deprecation warnings starting in WebKitGTK+ 2.21.1 for - webkit_javascript_result_get_global_context and - webkit_javascript_result_get_value (Bug#33679). - FIXME: Use the JavaScriptCore GLib API instead, and remove this hack. */ -#if WEBKIT_CHECK_VERSION (2, 21, 1) && GNUC_PREREQ (4, 2, 0) -# pragma GCC diagnostic ignored "-Wdeprecated-declarations" -#endif - static struct xwidget * allocate_xwidget (void) { @@ -284,95 +276,70 @@ webkit_view_load_changed_cb (WebKitWebView *webkitwebview, /* Recursively convert a JavaScript value to a Lisp value. */ static Lisp_Object -webkit_js_to_lisp (JSContextRef context, JSValueRef value) +webkit_js_to_lisp (JSCValue *value) { - switch (JSValueGetType (context, value)) + if (jsc_value_is_string (value)) { - case kJSTypeString: - { - JSStringRef js_str_value; - gchar *str_value; - gsize str_length; - - js_str_value = JSValueToStringCopy (context, value, NULL); - str_length = JSStringGetMaximumUTF8CStringSize (js_str_value); - str_value = (gchar *)g_malloc (str_length); - JSStringGetUTF8CString (js_str_value, str_value, str_length); - JSStringRelease (js_str_value); - return build_string (str_value); - } - case kJSTypeBoolean: - return (JSValueToBoolean (context, value)) ? Qt : Qnil; - case kJSTypeNumber: - return make_fixnum (JSValueToNumber (context, value, NULL)); - case kJSTypeObject: - { - if (JSValueIsArray (context, value)) - { - JSStringRef pname = JSStringCreateWithUTF8CString("length"); - JSValueRef len = JSObjectGetProperty (context, (JSObjectRef) value, - pname, NULL); - double dlen = JSValueToNumber (context, len, NULL); - JSStringRelease(pname); - - Lisp_Object obj; - if (! (0 <= dlen && dlen < PTRDIFF_MAX + 1.0)) - memory_full (SIZE_MAX); - ptrdiff_t n = dlen; - struct Lisp_Vector *p = allocate_vector (n); - - for (ptrdiff_t i = 0; i < n; ++i) - { - p->contents[i] = - webkit_js_to_lisp (context, - JSObjectGetPropertyAtIndex (context, - (JSObjectRef) value, - i, NULL)); - } - XSETVECTOR (obj, p); - return obj; - } - else - { - JSPropertyNameArrayRef properties = - JSObjectCopyPropertyNames (context, (JSObjectRef) value); - - size_t n = JSPropertyNameArrayGetCount (properties); - Lisp_Object obj; - - /* TODO: can we use a regular list here? */ - if (PTRDIFF_MAX < n) - memory_full (n); - struct Lisp_Vector *p = allocate_vector (n); - - for (ptrdiff_t i = 0; i < n; ++i) - { - JSStringRef name = JSPropertyNameArrayGetNameAtIndex (properties, i); - JSValueRef property = JSObjectGetProperty (context, - (JSObjectRef) value, - name, NULL); - gchar *str_name; - gsize str_length; - str_length = JSStringGetMaximumUTF8CStringSize (name); - str_name = (gchar *)g_malloc (str_length); - JSStringGetUTF8CString (name, str_name, str_length); - JSStringRelease (name); - - p->contents[i] = - Fcons (build_string (str_name), - webkit_js_to_lisp (context, property)); - } - - JSPropertyNameArrayRelease (properties); - XSETVECTOR (obj, p); - return obj; - } - } - case kJSTypeUndefined: - case kJSTypeNull: - default: - return Qnil; + gchar *str_value = jsc_value_to_string (value); + Lisp_Object ret = build_string (str_value); + g_free (str_value); + + return ret; + } + else if (jsc_value_is_boolean (value)) + { + return (jsc_value_to_boolean (value)) ? Qt : Qnil; + } + else if (jsc_value_is_number (value)) + { + return make_fixnum (jsc_value_to_int32 (value)); + } + else if (jsc_value_is_array (value)) + { + JSCValue *len = jsc_value_object_get_property (value, "length"); + const gint32 dlen = jsc_value_to_int32 (len); + + Lisp_Object obj; + if (! (0 <= dlen && dlen < PTRDIFF_MAX + 1.0)) + memory_full (SIZE_MAX); + + ptrdiff_t n = dlen; + struct Lisp_Vector *p = allocate_vector (n); + + for (ptrdiff_t i = 0; i < n; ++i) + { + p->contents[i] = + webkit_js_to_lisp (jsc_value_object_get_property_at_index (value, i)); + } + XSETVECTOR (obj, p); + return obj; + } + else if (jsc_value_is_object (value)) + { + char **properties_names = jsc_value_object_enumerate_properties (value); + guint n = g_strv_length (properties_names); + + Lisp_Object obj; + if (PTRDIFF_MAX < n) + memory_full (n); + struct Lisp_Vector *p = allocate_vector (n); + + for (ptrdiff_t i = 0; i < n; ++i) + { + const char *name = properties_names[i]; + JSCValue *property = jsc_value_object_get_property (value, name); + + p->contents[i] = + Fcons (build_string (name), webkit_js_to_lisp (property)); + } + + g_strfreev (properties_names); + + XSETVECTOR (obj, p); + return obj; } + + return Qnil; } static void @@ -380,41 +347,39 @@ webkit_javascript_finished_cb (GObject *webview, GAsyncResult *result, gpointer arg) { - WebKitJavascriptResult *js_result; - JSValueRef value; - JSGlobalContextRef context; - GError *error = NULL; - struct xwidget *xw = g_object_get_data (G_OBJECT (webview), - XG_XWIDGET); - ptrdiff_t script_idx = (intptr_t) arg; - Lisp_Object script_callback = AREF (xw->script_callbacks, script_idx); - ASET (xw->script_callbacks, script_idx, Qnil); - if (!NILP (script_callback)) - xfree (xmint_pointer (XCAR (script_callback))); - - js_result = webkit_web_view_run_javascript_finish - (WEBKIT_WEB_VIEW (webview), result, &error); - - if (!js_result) - { - g_warning ("Error running javascript: %s", error->message); - g_error_free (error); - return; - } + GError *error = NULL; + struct xwidget *xw = g_object_get_data (G_OBJECT (webview), XG_XWIDGET); - if (!NILP (script_callback) && !NILP (XCDR (script_callback))) - { - context = webkit_javascript_result_get_global_context (js_result); - value = webkit_javascript_result_get_value (js_result); - Lisp_Object lisp_value = webkit_js_to_lisp (context, value); - - /* Register an xwidget event here, which then runs the callback. - This ensures that the callback runs in sync with the Emacs - event loop. */ - store_xwidget_js_callback_event (xw, XCDR (script_callback), lisp_value); - } + ptrdiff_t script_idx = (intptr_t) arg; + Lisp_Object script_callback = AREF (xw->script_callbacks, script_idx); + ASET (xw->script_callbacks, script_idx, Qnil); + if (!NILP (script_callback)) + xfree (xmint_pointer (XCAR (script_callback))); + + WebKitJavascriptResult *js_result = + webkit_web_view_run_javascript_finish + (WEBKIT_WEB_VIEW (webview), result, &error); + + if (!js_result) + { + g_warning ("Error running javascript: %s", error->message); + g_error_free (error); + return; + } + + if (!NILP (script_callback) && !NILP (XCDR (script_callback))) + { + JSCValue *value = webkit_javascript_result_get_js_value (js_result); + + Lisp_Object lisp_value = webkit_js_to_lisp (value); + + /* Register an xwidget event here, which then runs the callback. + This ensures that the callback runs in sync with the Emacs + event loop. */ + store_xwidget_js_callback_event (xw, XCDR (script_callback), lisp_value); + } - webkit_javascript_result_unref (js_result); + webkit_javascript_result_unref (js_result); } |