1 /* File IO for GNU Emacs.
2
3 Copyright (C) 1985-1988, 1993-2021 Free Software Foundation, Inc.
4
5 This file is part of GNU Emacs.
6
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or (at
10 your option) any later version.
11
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
19
20 #include <config.h>
21 #include <limits.h>
22 #include <fcntl.h>
23 #include "sysstdio.h"
24 #include <sys/types.h>
25 #include <sys/stat.h>
26 #include <unistd.h>
27
28 #ifdef DARWIN_OS
29 #include <sys/attr.h>
30 #endif
31
32 #ifdef HAVE_PWD_H
33 #include <pwd.h>
34 #endif
35
36 #include <errno.h>
37
38 #ifdef HAVE_LIBSELINUX
39 #include <selinux/selinux.h>
40 #include <selinux/context.h>
41 #endif
42
43 #if USE_ACL && defined HAVE_ACL_SET_FILE
44 #include <sys/acl.h>
45 #endif
46
47 #include <c-ctype.h>
48
49 #include "lisp.h"
50 #include "composite.h"
51 #include "character.h"
52 #include "buffer.h"
53 #include "coding.h"
54 #include "window.h"
55 #include "blockinput.h"
56 #include "region-cache.h"
57 #include "frame.h"
58
59 #ifdef HAVE_LINUX_FS_H
60 # include <sys/ioctl.h>
61 # include <linux/fs.h>
62 #endif
63
64 #ifdef WINDOWSNT
65 #define NOMINMAX 1
66 #include <windows.h>
67 /* The redundant #ifdef is to avoid compiler warning about unused macro. */
68 #ifdef NOMINMAX
69 #undef NOMINMAX
70 #endif
71 #include <sys/file.h>
72 #include "w32.h"
73 #endif /* not WINDOWSNT */
74
75 #ifdef MSDOS
76 #include "msdos.h"
77 #include <sys/param.h>
78 #endif
79
80 #ifdef DOS_NT
81 /* On Windows, drive letters must be alphabetic - on DOS, the Netware
82 redirector allows the six letters between 'Z' and 'a' as well. */
83 #ifdef MSDOS
84 #define IS_DRIVE(x) ((x) >= 'A' && (x) <= 'z')
85 #endif
86 #ifdef WINDOWSNT
87 #define IS_DRIVE(x) c_isalpha (x)
88 #endif
89 /* Need to lower-case the drive letter, or else expanded
90 filenames will sometimes compare unequal, because
91 `expand-file-name' doesn't always down-case the drive letter. */
92 #define DRIVE_LETTER(x) c_tolower (x)
93 #endif
94
95 #include "systime.h"
96 #include <acl.h>
97 #include <allocator.h>
98 #include <careadlinkat.h>
99 #include <filename.h>
100 #include <fsusage.h>
101 #include <stat-time.h>
102 #include <tempname.h>
103
104 #include <binary-io.h>
105
106 #ifdef HPUX
107 #include <netio.h>
108 #endif
109
110 #include "commands.h"
111
112 /* True during writing of auto-save files. */
113 static bool auto_saving;
114
115 /* Emacs's real umask. */
116 static mode_t realmask;
117
118 /* Nonzero umask during creation of auto-save directories. */
119 static mode_t auto_saving_dir_umask;
120
121 /* Set by auto_save_1 to mode of original file so Fwrite_region will create
122 a new file with the same mode as the original. */
123 static mode_t auto_save_mode_bits;
124
125 /* Set by auto_save_1 if an error occurred during the last auto-save. */
126 static bool auto_save_error_occurred;
127
128 /* If VALID_TIMESTAMP_FILE_SYSTEM, then TIMESTAMP_FILE_SYSTEM is the device
129 number of a file system where time stamps were observed to work. */
130 static bool valid_timestamp_file_system;
131 static dev_t timestamp_file_system;
132
133 /* Each time an annotation function changes the buffer, the new buffer
134 is added here. */
135 static Lisp_Object Vwrite_region_annotation_buffers;
136
137 static Lisp_Object file_name_directory (Lisp_Object);
138 static bool a_write (int, Lisp_Object, ptrdiff_t, ptrdiff_t,
139 Lisp_Object *, struct coding_system *);
140 static bool e_write (int, Lisp_Object, ptrdiff_t, ptrdiff_t,
141 struct coding_system *);
142
143
144 /* Test whether FILE is accessible for AMODE.
145 Return true if successful, false (setting errno) otherwise. */
146
147 bool
file_access_p(char const * file,int amode)148 file_access_p (char const *file, int amode)
149 {
150 #ifdef MSDOS
151 if (amode & W_OK)
152 {
153 /* FIXME: The MS-DOS faccessat implementation should handle this. */
154 struct stat st;
155 if (stat (file, &st) != 0)
156 return false;
157 errno = EPERM;
158 return st.st_mode & S_IWRITE || S_ISDIR (st.st_mode);
159 }
160 #endif
161
162 if (faccessat (AT_FDCWD, file, amode, AT_EACCESS) == 0)
163 return true;
164
165 #ifdef CYGWIN
166 /* Return success if faccessat failed because Cygwin couldn't
167 determine the file's UID or GID. */
168 int err = errno;
169 struct stat st;
170 if (stat (file, &st) == 0 && (st.st_uid == -1 || st.st_gid == -1))
171 return true;
172 errno = err;
173 #endif
174
175 return false;
176 }
177
178 /* Signal a file-access failure. STRING describes the failure,
179 NAME the file involved, and ERRORNO the errno value.
180
181 If NAME is neither null nor a pair, package it up as a singleton
182 list before reporting it; this saves report_file_errno's caller the
183 trouble of preserving errno before calling list1. */
184
185 Lisp_Object
get_file_errno_data(char const * string,Lisp_Object name,int errorno)186 get_file_errno_data (char const *string, Lisp_Object name, int errorno)
187 {
188 Lisp_Object data = CONSP (name) || NILP (name) ? name : list1 (name);
189 char *str = emacs_strerror (errorno);
190 AUTO_STRING (unibyte_str, str);
191 Lisp_Object errstring
192 = code_convert_string_norecord (unibyte_str, Vlocale_coding_system, 0);
193 Lisp_Object errdata = Fcons (errstring, data);
194
195 if (errorno == EEXIST)
196 return Fcons (Qfile_already_exists, errdata);
197 else
198 return Fcons (errorno == ENOENT
199 ? Qfile_missing
200 : (errorno == EACCES
201 ? Qpermission_denied
202 : Qfile_error),
203 Fcons (build_string (string), errdata));
204 }
205
206 void
report_file_errno(char const * string,Lisp_Object name,int errorno)207 report_file_errno (char const *string, Lisp_Object name, int errorno)
208 {
209 Lisp_Object data = get_file_errno_data (string, name, errorno);
210
211 xsignal (Fcar (data), Fcdr (data));
212 }
213
214 /* Signal a file-access failure that set errno. STRING describes the
215 failure, NAME the file involved. When invoking this function, take
216 care to not use arguments such as build_string ("foo") that involve
217 side effects that may set errno. */
218
219 void
report_file_error(char const * string,Lisp_Object name)220 report_file_error (char const *string, Lisp_Object name)
221 {
222 report_file_errno (string, name, errno);
223 }
224
225 #ifdef USE_FILE_NOTIFY
226 /* Like report_file_error, but reports a file-notify-error instead. */
227
228 void
report_file_notify_error(const char * string,Lisp_Object name)229 report_file_notify_error (const char *string, Lisp_Object name)
230 {
231 char *str = emacs_strerror (errno);
232 AUTO_STRING (unibyte_str, str);
233 Lisp_Object errstring
234 = code_convert_string_norecord (unibyte_str, Vlocale_coding_system, 0);
235 Lisp_Object data = CONSP (name) || NILP (name) ? name : list1 (name);
236 Lisp_Object errdata = Fcons (errstring, data);
237
238 xsignal (Qfile_notify_error, Fcons (build_string (string), errdata));
239 }
240 #endif
241
242 /* ACTION failed for FILE with errno ERR. Signal an error if ERR
243 means the file's metadata could not be retrieved even though it may
244 exist, otherwise return nil. */
245
246 static Lisp_Object
file_metadata_errno(char const * action,Lisp_Object file,int err)247 file_metadata_errno (char const *action, Lisp_Object file, int err)
248 {
249 if (err == ENOENT || err == ENOTDIR || err == 0)
250 return Qnil;
251 report_file_errno (action, file, err);
252 }
253
254 Lisp_Object
file_attribute_errno(Lisp_Object file,int err)255 file_attribute_errno (Lisp_Object file, int err)
256 {
257 return file_metadata_errno ("Getting attributes", file, err);
258 }
259
260 void
close_file_unwind(int fd)261 close_file_unwind (int fd)
262 {
263 emacs_close (fd);
264 }
265
266 void
fclose_unwind(void * arg)267 fclose_unwind (void *arg)
268 {
269 FILE *stream = arg;
270 fclose (stream);
271 }
272
273 /* Restore point, having saved it as a marker. */
274
275 void
restore_point_unwind(Lisp_Object location)276 restore_point_unwind (Lisp_Object location)
277 {
278 Fgoto_char (location);
279 unchain_marker (XMARKER (location));
280 }
281
282
283 DEFUN ("find-file-name-handler", Ffind_file_name_handler,
284 Sfind_file_name_handler, 2, 2, 0,
285 doc: /* Return FILENAME's handler function for OPERATION, if it has one.
286 Otherwise, return nil.
287 A file name is handled if one of the regular expressions in
288 `file-name-handler-alist' matches it.
289
290 If OPERATION equals `inhibit-file-name-operation', then ignore
291 any handlers that are members of `inhibit-file-name-handlers',
292 but still do run any other handlers. This lets handlers
293 use the standard functions without calling themselves recursively. */)
294 (Lisp_Object filename, Lisp_Object operation)
295 {
296 /* This function must not munge the match data. */
297 Lisp_Object chain, inhibited_handlers, result;
298 ptrdiff_t pos = -1;
299
300 result = Qnil;
301 CHECK_STRING (filename);
302
303 if (EQ (operation, Vinhibit_file_name_operation))
304 inhibited_handlers = Vinhibit_file_name_handlers;
305 else
306 inhibited_handlers = Qnil;
307
308 for (chain = Vfile_name_handler_alist; CONSP (chain);
309 chain = XCDR (chain))
310 {
311 Lisp_Object elt;
312 elt = XCAR (chain);
313 if (CONSP (elt))
314 {
315 Lisp_Object string = XCAR (elt);
316 ptrdiff_t match_pos;
317 Lisp_Object handler = XCDR (elt);
318 Lisp_Object operations = Qnil;
319
320 if (SYMBOLP (handler))
321 operations = Fget (handler, Qoperations);
322
323 if (STRINGP (string)
324 && (match_pos = fast_string_match (string, filename)) > pos
325 && (NILP (operations) || ! NILP (Fmemq (operation, operations))))
326 {
327 Lisp_Object tem;
328
329 handler = XCDR (elt);
330 tem = Fmemq (handler, inhibited_handlers);
331 if (NILP (tem))
332 {
333 result = handler;
334 pos = match_pos;
335 }
336 }
337 }
338
339 maybe_quit ();
340 }
341 return result;
342 }
343
344 DEFUN ("file-name-directory", Ffile_name_directory, Sfile_name_directory,
345 1, 1, 0,
346 doc: /* Return the directory component in file name FILENAME.
347 Return nil if FILENAME does not include a directory.
348 Otherwise return a directory name.
349 Given a Unix syntax file name, returns a string ending in slash. */)
350 (Lisp_Object filename)
351 {
352 Lisp_Object handler;
353
354 CHECK_STRING (filename);
355
356 /* If the file name has special constructs in it,
357 call the corresponding file name handler. */
358 handler = Ffind_file_name_handler (filename, Qfile_name_directory);
359 if (!NILP (handler))
360 {
361 Lisp_Object handled_name = call2 (handler, Qfile_name_directory,
362 filename);
363 return STRINGP (handled_name) ? handled_name : Qnil;
364 }
365
366 return file_name_directory (filename);
367 }
368
369 /* Return the directory component of FILENAME, or nil if FILENAME does
370 not contain a directory component. */
371
372 static Lisp_Object
file_name_directory(Lisp_Object filename)373 file_name_directory (Lisp_Object filename)
374 {
375 char *beg = SSDATA (filename);
376 char const *p = beg + SBYTES (filename);
377
378 while (p != beg && !IS_DIRECTORY_SEP (p[-1])
379 #ifdef DOS_NT
380 /* only recognize drive specifier at the beginning */
381 && !(p[-1] == ':'
382 /* handle the "/:d:foo" and "/:foo" cases correctly */
383 && ((p == beg + 2 && !IS_DIRECTORY_SEP (*beg))
384 || (p == beg + 4 && IS_DIRECTORY_SEP (*beg))))
385 #endif
386 ) p--;
387
388 if (p == beg)
389 return Qnil;
390 #ifdef DOS_NT
391 /* Expansion of "c:" to drive and default directory. */
392 Lisp_Object tem_fn;
393 USE_SAFE_ALLOCA;
394 SAFE_ALLOCA_STRING (beg, filename);
395 p = beg + (p - SSDATA (filename));
396
397 if (p[-1] == ':')
398 {
399 /* MAXPATHLEN+1 is guaranteed to be enough space for getdefdir. */
400 char *res = alloca (MAXPATHLEN + 1);
401 char *r = res;
402
403 if (p == beg + 4 && IS_DIRECTORY_SEP (*beg) && beg[1] == ':')
404 {
405 memcpy (res, beg, 2);
406 beg += 2;
407 r += 2;
408 }
409
410 if (getdefdir (c_toupper (*beg) - 'A' + 1, r))
411 {
412 size_t l = strlen (res);
413
414 if (l > 3 || !IS_DIRECTORY_SEP (res[l - 1]))
415 strcat (res, "/");
416 beg = res;
417 p = beg + strlen (beg);
418 dostounix_filename (beg);
419 tem_fn = make_specified_string (beg, -1, p - beg,
420 STRING_MULTIBYTE (filename));
421 }
422 else
423 tem_fn = make_specified_string (beg - 2, -1, p - beg + 2,
424 STRING_MULTIBYTE (filename));
425 }
426 else if (STRING_MULTIBYTE (filename))
427 {
428 tem_fn = make_specified_string (beg, -1, p - beg, 1);
429 dostounix_filename (SSDATA (tem_fn));
430 #ifdef WINDOWSNT
431 if (!NILP (Vw32_downcase_file_names))
432 tem_fn = Fdowncase (tem_fn);
433 #endif
434 }
435 else
436 {
437 dostounix_filename (beg);
438 tem_fn = make_specified_string (beg, -1, p - beg, 0);
439 }
440 SAFE_FREE ();
441 return tem_fn;
442 #else /* DOS_NT */
443 return make_specified_string (beg, -1, p - beg, STRING_MULTIBYTE (filename));
444 #endif /* DOS_NT */
445 }
446
447 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory,
448 Sfile_name_nondirectory, 1, 1, 0,
449 doc: /* Return file name FILENAME sans its directory.
450 For example, in a Unix-syntax file name,
451 this is everything after the last slash,
452 or the entire name if it contains no slash. */)
453 (Lisp_Object filename)
454 {
455 register const char *beg, *p, *end;
456 Lisp_Object handler;
457
458 CHECK_STRING (filename);
459
460 /* If the file name has special constructs in it,
461 call the corresponding file name handler. */
462 handler = Ffind_file_name_handler (filename, Qfile_name_nondirectory);
463 if (!NILP (handler))
464 {
465 Lisp_Object handled_name = call2 (handler, Qfile_name_nondirectory,
466 filename);
467 if (STRINGP (handled_name))
468 return handled_name;
469 error ("Invalid handler in `file-name-handler-alist'");
470 }
471
472 beg = SSDATA (filename);
473 end = p = beg + SBYTES (filename);
474
475 while (p != beg && !IS_DIRECTORY_SEP (p[-1])
476 #ifdef DOS_NT
477 /* only recognize drive specifier at beginning */
478 && !(p[-1] == ':'
479 /* handle the "/:d:foo" case correctly */
480 && (p == beg + 2 || (p == beg + 4 && IS_DIRECTORY_SEP (*beg))))
481 #endif
482 )
483 p--;
484
485 return make_specified_string (p, -1, end - p, STRING_MULTIBYTE (filename));
486 }
487
488 DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory,
489 Sunhandled_file_name_directory, 1, 1, 0,
490 doc: /* Return a directly usable directory name somehow associated with FILENAME.
491 A `directly usable' directory name is one that may be used without the
492 intervention of any file name handler.
493 If FILENAME is a directly usable file itself, return
494 \(file-name-as-directory FILENAME).
495 If FILENAME refers to a file which is not accessible from a local process,
496 then this should return nil.
497 The `call-process' and `start-process' functions use this function to
498 get a current directory to run processes in. */)
499 (Lisp_Object filename)
500 {
501 Lisp_Object handler;
502
503 /* If the file name has special constructs in it,
504 call the corresponding file name handler. */
505 handler = Ffind_file_name_handler (filename, Qunhandled_file_name_directory);
506 if (!NILP (handler))
507 {
508 Lisp_Object handled_name = call2 (handler, Qunhandled_file_name_directory,
509 filename);
510 return STRINGP (handled_name) ? handled_name : Qnil;
511 }
512
513 return Ffile_name_as_directory (filename);
514 }
515
516 /* Maximum number of bytes that DST will be longer than SRC
517 in file_name_as_directory. This occurs when SRCLEN == 0. */
518 enum { file_name_as_directory_slop = 2 };
519
520 /* Convert from file name SRC of length SRCLEN to directory name in
521 DST. MULTIBYTE non-zero means the file name in SRC is a multibyte
522 string. On UNIX, just make sure there is a terminating /. Return
523 the length of DST in bytes. */
524
525 static ptrdiff_t
file_name_as_directory(char * dst,const char * src,ptrdiff_t srclen,bool multibyte)526 file_name_as_directory (char *dst, const char *src, ptrdiff_t srclen,
527 bool multibyte)
528 {
529 if (srclen == 0)
530 {
531 dst[0] = '.';
532 dst[1] = '/';
533 dst[2] = '\0';
534 return 2;
535 }
536
537 memcpy (dst, src, srclen);
538 if (!IS_DIRECTORY_SEP (dst[srclen - 1]))
539 dst[srclen++] = DIRECTORY_SEP;
540 dst[srclen] = 0;
541 #ifdef DOS_NT
542 dostounix_filename (dst);
543 #endif
544 return srclen;
545 }
546
547 DEFUN ("file-name-as-directory", Ffile_name_as_directory,
548 Sfile_name_as_directory, 1, 1, 0,
549 doc: /* Return a string representing the file name FILE interpreted as a directory.
550 This operation exists because a directory is also a file, but its name as
551 a directory is different from its name as a file.
552 The result can be used as the value of `default-directory'
553 or passed as second argument to `expand-file-name'.
554 For a Unix-syntax file name, just appends a slash unless a trailing slash
555 is already present. */)
556 (Lisp_Object file)
557 {
558 char *buf;
559 ptrdiff_t length;
560 Lisp_Object handler, val;
561 USE_SAFE_ALLOCA;
562
563 CHECK_STRING (file);
564
565 /* If the file name has special constructs in it,
566 call the corresponding file name handler. */
567 handler = Ffind_file_name_handler (file, Qfile_name_as_directory);
568 if (!NILP (handler))
569 {
570 Lisp_Object handled_name = call2 (handler, Qfile_name_as_directory,
571 file);
572 if (STRINGP (handled_name))
573 return handled_name;
574 error ("Invalid handler in `file-name-handler-alist'");
575 }
576
577 #ifdef WINDOWSNT
578 if (!NILP (Vw32_downcase_file_names))
579 file = Fdowncase (file);
580 #endif
581 buf = SAFE_ALLOCA (SBYTES (file) + file_name_as_directory_slop + 1);
582 length = file_name_as_directory (buf, SSDATA (file), SBYTES (file),
583 STRING_MULTIBYTE (file));
584 val = make_specified_string (buf, -1, length, STRING_MULTIBYTE (file));
585 SAFE_FREE ();
586 return val;
587 }
588
589 /* Convert from directory name SRC of length SRCLEN to file name in
590 DST. MULTIBYTE non-zero means the file name in SRC is a multibyte
591 string. On UNIX, just make sure there isn't a terminating /.
592 Return the length of DST in bytes. */
593
594 static ptrdiff_t
directory_file_name(char * dst,char * src,ptrdiff_t srclen,bool multibyte)595 directory_file_name (char *dst, char *src, ptrdiff_t srclen, bool multibyte)
596 {
597 /* In Unix-like systems, just remove any final slashes. However, if
598 they are all slashes, leave "/" and "//" alone, and treat "///"
599 and longer as if they were "/". */
600 if (! (srclen == 2 && IS_DIRECTORY_SEP (src[0])))
601 while (srclen > 1
602 #ifdef DOS_NT
603 && !(srclen > 2 && IS_DEVICE_SEP (src[srclen - 2]))
604 #endif
605 && IS_DIRECTORY_SEP (src[srclen - 1]))
606 srclen--;
607
608 memcpy (dst, src, srclen);
609 dst[srclen] = 0;
610 #ifdef DOS_NT
611 dostounix_filename (dst);
612 #endif
613 return srclen;
614 }
615
616 DEFUN ("directory-name-p", Fdirectory_name_p, Sdirectory_name_p, 1, 1, 0,
617 doc: /* Return non-nil if NAME ends with a directory separator character. */)
618 (Lisp_Object name)
619 {
620 CHECK_STRING (name);
621 ptrdiff_t namelen = SBYTES (name);
622 unsigned char c = namelen ? SREF (name, namelen - 1) : 0;
623 return IS_DIRECTORY_SEP (c) ? Qt : Qnil;
624 }
625
626 /* Return the expansion of NEWNAME, except that if NEWNAME is a
627 directory name then return the expansion of FILE's basename under
628 NEWNAME. This resembles how 'cp FILE NEWNAME' works, except that
629 it requires NEWNAME to be a directory name (typically, by ending in
630 "/"). */
631
632 static Lisp_Object
expand_cp_target(Lisp_Object file,Lisp_Object newname)633 expand_cp_target (Lisp_Object file, Lisp_Object newname)
634 {
635 return (!NILP (Fdirectory_name_p (newname))
636 ? Fexpand_file_name (Ffile_name_nondirectory (file), newname)
637 : Fexpand_file_name (newname, Qnil));
638 }
639
640 DEFUN ("directory-file-name", Fdirectory_file_name, Sdirectory_file_name,
641 1, 1, 0,
642 doc: /* Returns the file name of the directory named DIRECTORY.
643 This is the name of the file that holds the data for the directory DIRECTORY.
644 This operation exists because a directory is also a file, but its name as
645 a directory is different from its name as a file.
646 In Unix-syntax, this function just removes the final slash. */)
647 (Lisp_Object directory)
648 {
649 char *buf;
650 ptrdiff_t length;
651 Lisp_Object handler, val;
652 USE_SAFE_ALLOCA;
653
654 CHECK_STRING (directory);
655
656 /* If the file name has special constructs in it,
657 call the corresponding file name handler. */
658 handler = Ffind_file_name_handler (directory, Qdirectory_file_name);
659 if (!NILP (handler))
660 {
661 Lisp_Object handled_name = call2 (handler, Qdirectory_file_name,
662 directory);
663 if (STRINGP (handled_name))
664 return handled_name;
665 error ("Invalid handler in `file-name-handler-alist'");
666 }
667
668 #ifdef WINDOWSNT
669 if (!NILP (Vw32_downcase_file_names))
670 directory = Fdowncase (directory);
671 #endif
672 buf = SAFE_ALLOCA (SBYTES (directory) + 1);
673 length = directory_file_name (buf, SSDATA (directory), SBYTES (directory),
674 STRING_MULTIBYTE (directory));
675 val = make_specified_string (buf, -1, length, STRING_MULTIBYTE (directory));
676 SAFE_FREE ();
677 return val;
678 }
679
680 DEFUN ("make-temp-file-internal", Fmake_temp_file_internal,
681 Smake_temp_file_internal, 4, 4, 0,
682 doc: /* Generate a new file whose name starts with PREFIX, a string.
683 Return the name of the generated file. If DIR-FLAG is zero, do not
684 create the file, just its name. Otherwise, if DIR-FLAG is non-nil,
685 create an empty directory. The file name should end in SUFFIX.
686 Do not expand PREFIX; a non-absolute PREFIX is relative to the Emacs
687 working directory. If TEXT is a string, insert it into the newly
688 created file.
689
690 Signal an error if the file could not be created.
691
692 This function does not grok magic file names. */)
693 (Lisp_Object prefix, Lisp_Object dir_flag, Lisp_Object suffix,
694 Lisp_Object text)
695 {
696 CHECK_STRING (prefix);
697 CHECK_STRING (suffix);
698 Lisp_Object encoded_prefix = ENCODE_FILE (prefix);
699 Lisp_Object encoded_suffix = ENCODE_FILE (suffix);
700 ptrdiff_t prefix_len = SBYTES (encoded_prefix);
701 ptrdiff_t suffix_len = SBYTES (encoded_suffix);
702 if (INT_MAX < suffix_len)
703 args_out_of_range (prefix, suffix);
704 int nX = 6;
705 Lisp_Object val = make_uninit_string (prefix_len + nX + suffix_len);
706 char *data = SSDATA (val);
707 memcpy (data, SSDATA (encoded_prefix), prefix_len);
708 memset (data + prefix_len, 'X', nX);
709 memcpy (data + prefix_len + nX, SSDATA (encoded_suffix), suffix_len);
710 int kind = (NILP (dir_flag) ? GT_FILE
711 : EQ (dir_flag, make_fixnum (0)) ? GT_NOCREATE
712 : GT_DIR);
713 int fd = gen_tempname (data, suffix_len, O_BINARY | O_CLOEXEC, kind);
714 bool failed = fd < 0;
715 if (!failed)
716 {
717 ptrdiff_t count = SPECPDL_INDEX ();
718 record_unwind_protect_int (close_file_unwind, fd);
719 val = DECODE_FILE (val);
720 if (STRINGP (text) && SBYTES (text) != 0)
721 write_region (text, Qnil, val, Qnil, Qnil, Qnil, Qnil, fd);
722 failed = NILP (dir_flag) && emacs_close (fd) != 0;
723 /* Discard the unwind protect. */
724 specpdl_ptr = specpdl + count;
725 }
726 if (failed)
727 {
728 static char const kind_message[][32] =
729 {
730 [GT_FILE] = "Creating file with prefix",
731 [GT_DIR] = "Creating directory with prefix",
732 [GT_NOCREATE] = "Creating file name with prefix"
733 };
734 report_file_error (kind_message[kind], prefix);
735 }
736 return val;
737 }
738
739
740 DEFUN ("make-temp-name", Fmake_temp_name, Smake_temp_name, 1, 1, 0,
741 doc: /* Generate temporary file name (string) starting with PREFIX (a string).
742
743 This function tries to choose a name that has no existing file.
744 For this to work, PREFIX should be an absolute file name, and PREFIX
745 and the returned string should both be non-magic.
746
747 There is a race condition between calling `make-temp-name' and
748 later creating the file, which opens all kinds of security holes.
749 For that reason, you should normally use `make-temp-file' instead. */)
750 (Lisp_Object prefix)
751 {
752 return Fmake_temp_file_internal (prefix, make_fixnum (0),
753 empty_unibyte_string, Qnil);
754 }
755
756 DEFUN ("file-name-concat", Ffile_name_concat, Sfile_name_concat, 1, MANY, 0,
757 doc: /* Append COMPONENTS to DIRECTORY and return the resulting string.
758 Elements in COMPONENTS must be a string or nil.
759 DIRECTORY or the non-final elements in COMPONENTS may or may not end
760 with a slash -- if they don't end with a slash, a slash will be
761 inserted before contatenating.
762 usage: (record DIRECTORY &rest COMPONENTS) */)
763 (ptrdiff_t nargs, Lisp_Object *args)
764 {
765 ptrdiff_t chars = 0, bytes = 0, multibytes = 0, eargs = 0;
766 Lisp_Object *elements = args;
767 Lisp_Object result;
768 ptrdiff_t i;
769
770 /* First go through the list to check the types and see whether
771 they're all of the same multibytedness. */
772 for (i = 0; i < nargs; i++)
773 {
774 Lisp_Object arg = args[i];
775 /* Skip empty and nil elements. */
776 if (NILP (arg))
777 continue;
778 CHECK_STRING (arg);
779 if (SCHARS (arg) == 0)
780 continue;
781 eargs++;
782 /* Multibyte and non-ASCII. */
783 if (STRING_MULTIBYTE (arg) && SCHARS (arg) != SBYTES (arg))
784 multibytes++;
785 /* We're not adding a slash to the final part. */
786 if (i == nargs - 1
787 || IS_DIRECTORY_SEP (*(SSDATA (arg) + SBYTES (arg) - 1)))
788 {
789 bytes += SBYTES (arg);
790 chars += SCHARS (arg);
791 }
792 else
793 {
794 bytes += SBYTES (arg) + 1;
795 chars += SCHARS (arg) + 1;
796 }
797 }
798
799 /* Convert if needed. */
800 if ((multibytes != 0 && multibytes != nargs)
801 || eargs != nargs)
802 {
803 int j = 0;
804 elements = xmalloc (eargs * sizeof *elements);
805 bytes = 0;
806 chars = 0;
807
808 /* Filter out nil/"". */
809 for (i = 0; i < nargs; i++)
810 {
811 Lisp_Object arg = args[i];
812 if (!NILP (arg) && SCHARS (arg) != 0)
813 elements[j++] = arg;
814 }
815
816 for (i = 0; i < eargs; i++)
817 {
818 Lisp_Object arg = elements[i];
819 /* Use multibyte or all-ASCII strings as is. */
820 if (!STRING_MULTIBYTE (arg) && !string_ascii_p (arg))
821 elements[i] = Fstring_to_multibyte (arg);
822 arg = elements[i];
823 /* We have to recompute the number of bytes. */
824 if (i == eargs - 1
825 || IS_DIRECTORY_SEP (*(SSDATA (arg) + SBYTES (arg) - 1)))
826 {
827 bytes += SBYTES (arg);
828 chars += SCHARS (arg);
829 }
830 else
831 {
832 bytes += SBYTES (arg) + 1;
833 chars += SCHARS (arg) + 1;
834 }
835 }
836 }
837
838 /* Allocate an empty string. */
839 if (multibytes == 0)
840 result = make_uninit_string (chars);
841 else
842 result = make_uninit_multibyte_string (chars, bytes);
843 /* Null-terminate the string. */
844 *(SSDATA (result) + SBYTES (result)) = 0;
845
846 /* Copy over the data. */
847 char *p = SSDATA (result);
848 for (i = 0; i < eargs; i++)
849 {
850 Lisp_Object arg = elements[i];
851 memcpy (p, SSDATA (arg), SBYTES (arg));
852 p += SBYTES (arg);
853 /* The last element shouldn't have a slash added at the end. */
854 if (i < eargs - 1 && !IS_DIRECTORY_SEP (*(p - 1)))
855 *p++ = DIRECTORY_SEP;
856 }
857
858 if (elements != args)
859 xfree (elements);
860
861 return result;
862 }
863
864 /* NAME must be a string. */
865 static bool
file_name_absolute_no_tilde_p(Lisp_Object name)866 file_name_absolute_no_tilde_p (Lisp_Object name)
867 {
868 return IS_ABSOLUTE_FILE_NAME (SSDATA (name));
869 }
870
871 /* Return the home directory of the user NAME, or a null pointer if
872 NAME is empty or the user does not exist or the user's home
873 directory is not an absolute file name. NAME is an array of bytes
874 that continues up to (but not including) the next NUL byte or
875 directory separator. The returned string lives in storage good
876 until the next call to this or similar functions. */
877 static char *
user_homedir(char const * name)878 user_homedir (char const *name)
879 {
880 ptrdiff_t length;
881 for (length = 0; name[length] && !IS_DIRECTORY_SEP (name[length]); length++)
882 continue;
883 if (length == 0)
884 return NULL;
885 USE_SAFE_ALLOCA;
886 char *p = SAFE_ALLOCA (length + 1);
887 memcpy (p, name, length);
888 p[length] = 0;
889 struct passwd *pw = getpwnam (p);
890 SAFE_FREE ();
891 if (!pw || (pw->pw_dir && !IS_ABSOLUTE_FILE_NAME (pw->pw_dir)))
892 return NULL;
893 return pw->pw_dir;
894 }
895
896 DEFUN ("expand-file-name", Fexpand_file_name, Sexpand_file_name, 1, 2, 0,
897 doc: /* Convert filename NAME to absolute, and canonicalize it.
898 Second arg DEFAULT-DIRECTORY is directory to start with if NAME is relative
899 \(does not start with slash or tilde); both the directory name and
900 a directory's file name are accepted. If DEFAULT-DIRECTORY is nil or
901 missing, the current buffer's value of `default-directory' is used.
902 NAME should be a string that is a valid file name for the underlying
903 filesystem.
904
905 File name components that are `.' are removed, and so are file name
906 components followed by `..', along with the `..' itself; note that
907 these simplifications are done without checking the resulting file
908 names in the file system.
909
910 Multiple consecutive slashes are collapsed into a single slash, except
911 at the beginning of the file name when they are significant (e.g., UNC
912 file names on MS-Windows.)
913
914 An initial \"~\" in NAME expands to your home directory.
915
916 An initial \"~USER\" in NAME expands to USER's home directory. If
917 USER doesn't exist, \"~USER\" is not expanded.
918
919 To do other file name substitutions, see `substitute-in-file-name'.
920
921 For technical reasons, this function can return correct but
922 non-intuitive results for the root directory; for instance,
923 \(expand-file-name ".." "/") returns "/..". For this reason, use
924 \(directory-file-name (file-name-directory dirname)) to traverse a
925 filesystem tree, not (expand-file-name ".." dirname). Note: make
926 sure DIRNAME in this example doesn't end in a slash, unless it's
927 the root directory. */)
928 (Lisp_Object name, Lisp_Object default_directory)
929 {
930 /* These point to SDATA and need to be careful with string-relocation
931 during GC (via DECODE_FILE). */
932 char *nm;
933 char *nmlim;
934 const char *newdir;
935 const char *newdirlim;
936 /* This should only point to alloca'd data. */
937 char *target;
938
939 ptrdiff_t tlen;
940 #ifdef DOS_NT
941 int drive = 0;
942 bool collapse_newdir = true;
943 bool is_escaped = 0;
944 #endif /* DOS_NT */
945 ptrdiff_t length, nbytes;
946 Lisp_Object handler, result, handled_name;
947 bool multibyte;
948 Lisp_Object hdir;
949 USE_SAFE_ALLOCA;
950
951 CHECK_STRING (name);
952 CHECK_STRING_NULL_BYTES (name);
953
954 /* If the file name has special constructs in it,
955 call the corresponding file name handler. */
956 handler = Ffind_file_name_handler (name, Qexpand_file_name);
957 if (!NILP (handler))
958 {
959 handled_name = call3 (handler, Qexpand_file_name,
960 name, default_directory);
961 if (STRINGP (handled_name))
962 return handled_name;
963 error ("Invalid handler in `file-name-handler-alist'");
964 }
965
966 /* As a last resort, we may have to use the root as
967 default_directory below. */
968 Lisp_Object root;
969 #ifdef DOS_NT
970 /* "/" is not considered a root directory on DOS_NT, so using it
971 as default_directory causes an infinite recursion in, e.g.,
972 the following:
973
974 (let (default-directory)
975 (expand-file-name "a"))
976
977 To avoid this, we use the root of the current drive. */
978 root = build_string (emacs_root_dir ());
979 #else
980 root = build_string ("/");
981 #endif
982
983 /* Use the buffer's default-directory if DEFAULT_DIRECTORY is omitted. */
984 if (NILP (default_directory))
985 {
986 Lisp_Object dir = BVAR (current_buffer, directory);
987 /* The buffer's default-directory should be absolute or should
988 start with `~'. If it isn't absolute, we replace it by its
989 expansion relative to a known absolute name ABSDIR, which is
990 the invocation-directory if the latter is absolute, or the
991 root otherwise.
992
993 In case default-directory starts with `~' or `~user', where
994 USER is a valid user name, this correctly expands it (and
995 ABSDIR plays no role). If USER is not a valid user name, the
996 leading `~' loses its special meaning and is retained as part
997 of the expanded name. */
998 if (STRINGP (dir))
999 {
1000 if (file_name_absolute_no_tilde_p (dir))
1001 {
1002 CHECK_STRING_NULL_BYTES (dir);
1003 default_directory = dir;
1004 }
1005 else
1006 {
1007 Lisp_Object absdir
1008 = STRINGP (Vinvocation_directory)
1009 && file_name_absolute_no_tilde_p (Vinvocation_directory)
1010 ? Vinvocation_directory : root;
1011 default_directory = Fexpand_file_name (dir, absdir);
1012 }
1013 }
1014 }
1015 if (! STRINGP (default_directory))
1016 default_directory = root;
1017
1018 handler = Ffind_file_name_handler (default_directory, Qexpand_file_name);
1019 if (!NILP (handler))
1020 {
1021 handled_name = call3 (handler, Qexpand_file_name,
1022 name, default_directory);
1023 if (STRINGP (handled_name))
1024 return handled_name;
1025 error ("Invalid handler in `file-name-handler-alist'");
1026 }
1027
1028 {
1029 char *o = SSDATA (default_directory);
1030
1031 /* Make sure DEFAULT_DIRECTORY is properly expanded.
1032 It would be better to do this down below where we actually use
1033 default_directory. Unfortunately, calling Fexpand_file_name recursively
1034 could invoke GC, and the strings might be relocated. This would
1035 be annoying because we have pointers into strings lying around
1036 that would need adjusting, and people would add new pointers to
1037 the code and forget to adjust them, resulting in intermittent bugs.
1038 Putting this call here avoids all that crud.
1039
1040 The EQ test avoids infinite recursion. */
1041 if (! NILP (default_directory) && !EQ (default_directory, name)
1042 /* Save time in some common cases - as long as default_directory
1043 is not relative, it can be canonicalized with name below (if it
1044 is needed at all) without requiring it to be expanded now. */
1045 #ifdef DOS_NT
1046 /* Detect MSDOS file names with drive specifiers. */
1047 && ! (IS_DRIVE (o[0]) && IS_DEVICE_SEP (o[1])
1048 && IS_DIRECTORY_SEP (o[2]))
1049 /* Detect escaped file names without drive spec after "/:".
1050 These should not be recursively expanded, to avoid
1051 including the default directory twice in the expanded
1052 result. */
1053 && ! (o[0] == '/' && o[1] == ':')
1054 #ifdef WINDOWSNT
1055 /* Detect Windows file names in UNC format. */
1056 && ! (IS_DIRECTORY_SEP (o[0]) && IS_DIRECTORY_SEP (o[1]))
1057 #endif
1058 #else /* not DOS_NT */
1059 /* Detect Unix absolute file names (/... alone is not absolute on
1060 DOS or Windows). */
1061 && ! (IS_DIRECTORY_SEP (o[0]))
1062 #endif /* not DOS_NT */
1063 )
1064 {
1065 default_directory = Fexpand_file_name (default_directory, Qnil);
1066
1067 /* The above expansion might have produced a remote file name,
1068 so give the handlers one last chance to DTRT. This can
1069 happen when both NAME and DEFAULT-DIRECTORY arguments are
1070 relative file names, and the buffer's default-directory is
1071 remote. */
1072 handler = Ffind_file_name_handler (default_directory,
1073 Qexpand_file_name);
1074 if (!NILP (handler))
1075 {
1076 handled_name = call3 (handler, Qexpand_file_name,
1077 name, default_directory);
1078 if (STRINGP (handled_name))
1079 return handled_name;
1080 error ("Invalid handler in `file-name-handler-alist'");
1081 }
1082 }
1083 }
1084 multibyte = STRING_MULTIBYTE (name);
1085 bool defdir_multibyte = STRING_MULTIBYTE (default_directory);
1086 if (multibyte != defdir_multibyte)
1087 {
1088 /* We want to make both NAME and DEFAULT_DIRECTORY have the same
1089 multibyteness. Strategy:
1090 . If either NAME or DEFAULT_DIRECTORY is pure-ASCII, they
1091 can be converted to the multibyteness of the other one
1092 while keeping the same byte sequence.
1093 . If both are non-ASCII, the only safe conversion is to
1094 convert the multibyte one to be unibyte, because the
1095 reverse conversion potentially adds bytes while raw bytes
1096 are converted to their multibyte forms, which we will be
1097 unable to account for, since the information about the
1098 original multibyteness is lost. If those additional bytes
1099 later leak to system APIs because they are not encoded or
1100 because they are converted to unibyte strings by keeping
1101 the data, file APIs will fail.
1102
1103 Note: One could argue that if we see a multibyte string, it
1104 is evidence that file-name decoding was already set up, and
1105 we could convert unibyte strings to multibyte using
1106 DECODE_FILE. However, this is risky, because the likes of
1107 string_to_multibyte are able of creating multibyte strings
1108 without any decoding. */
1109 if (multibyte)
1110 {
1111 bool name_ascii_p = SCHARS (name) == SBYTES (name);
1112 unsigned char *p = SDATA (default_directory);
1113
1114 if (!name_ascii_p)
1115 while (*p && ASCII_CHAR_P (*p))
1116 p++;
1117 if (name_ascii_p || *p != '\0')
1118 {
1119 /* DEFAULT_DIRECTORY is unibyte and possibly non-ASCII.
1120 Make a unibyte string out of NAME, and arrange for
1121 the result of this function to be a unibyte string.
1122 This is needed during bootstrapping and dumping, when
1123 Emacs cannot decode file names, because the locale
1124 environment is not set up. */
1125 name = make_unibyte_string (SSDATA (name), SBYTES (name));
1126 multibyte = 0;
1127 }
1128 else
1129 {
1130 /* NAME is non-ASCII and multibyte, and
1131 DEFAULT_DIRECTORY is unibyte and pure-ASCII: make a
1132 multibyte string out of DEFAULT_DIRECTORY's data. */
1133 default_directory =
1134 make_multibyte_string (SSDATA (default_directory),
1135 SCHARS (default_directory),
1136 SCHARS (default_directory));
1137 }
1138 }
1139 else
1140 {
1141 unsigned char *p = SDATA (name);
1142
1143 while (*p && ASCII_CHAR_P (*p))
1144 p++;
1145 if (*p == '\0')
1146 {
1147 /* DEFAULT_DIRECTORY is multibyte and NAME is unibyte
1148 and pure-ASCII. Make a multibyte string out of
1149 NAME's data. */
1150 name = make_multibyte_string (SSDATA (name),
1151 SCHARS (name), SCHARS (name));
1152 multibyte = 1;
1153 }
1154 else
1155 default_directory = make_unibyte_string (SSDATA (default_directory),
1156 SBYTES (default_directory));
1157 }
1158 }
1159
1160 #ifdef WINDOWSNT
1161 if (!NILP (Vw32_downcase_file_names))
1162 default_directory = Fdowncase (default_directory);
1163 #endif
1164
1165 /* Make a local copy of NAME to protect it from GC in DECODE_FILE below. */
1166 SAFE_ALLOCA_STRING (nm, name);
1167 nmlim = nm + SBYTES (name);
1168
1169 #ifdef DOS_NT
1170 /* Note if special escape prefix is present, but remove for now. */
1171 if (nm[0] == '/' && nm[1] == ':')
1172 {
1173 is_escaped = 1;
1174 nm += 2;
1175 }
1176
1177 /* Find and remove drive specifier if present; this makes nm absolute
1178 even if the rest of the name appears to be relative. Only look for
1179 drive specifier at the beginning. */
1180 if (IS_DRIVE (nm[0]) && IS_DEVICE_SEP (nm[1]))
1181 {
1182 drive = (unsigned char) nm[0];
1183 nm += 2;
1184 }
1185
1186 #ifdef WINDOWSNT
1187 /* If we see "c://somedir", we want to strip the first slash after the
1188 colon when stripping the drive letter. Otherwise, this expands to
1189 "//somedir". */
1190 if (drive && IS_DIRECTORY_SEP (nm[0]) && IS_DIRECTORY_SEP (nm[1]))
1191 nm++;
1192
1193 /* Discard any previous drive specifier if nm is now in UNC format. */
1194 if (IS_DIRECTORY_SEP (nm[0]) && IS_DIRECTORY_SEP (nm[1])
1195 && !IS_DIRECTORY_SEP (nm[2]))
1196 drive = 0;
1197 #endif /* WINDOWSNT */
1198 #endif /* DOS_NT */
1199
1200 /* If nm is absolute, look for `/./' or `/../' or `//''sequences; if
1201 none are found, we can probably return right away. We will avoid
1202 allocating a new string if name is already fully expanded. */
1203 if (
1204 IS_DIRECTORY_SEP (nm[0])
1205 #ifdef MSDOS
1206 && drive && !is_escaped
1207 #endif
1208 #ifdef WINDOWSNT
1209 && (drive || IS_DIRECTORY_SEP (nm[1])) && !is_escaped
1210 #endif
1211 )
1212 {
1213 /* If it turns out that the filename we want to return is just a
1214 suffix of FILENAME, we don't need to go through and edit
1215 things; we just need to construct a new string using data
1216 starting at the middle of FILENAME. If we set LOSE, that
1217 means we've discovered that we can't do that cool trick. */
1218 bool lose = 0;
1219 char *p = nm;
1220
1221 while (*p)
1222 {
1223 /* Since we know the name is absolute, we can assume that each
1224 element starts with a "/". */
1225
1226 /* "." and ".." are hairy. */
1227 if (IS_DIRECTORY_SEP (p[0])
1228 && p[1] == '.'
1229 && (IS_DIRECTORY_SEP (p[2])
1230 || p[2] == 0
1231 || (p[2] == '.' && (IS_DIRECTORY_SEP (p[3])
1232 || p[3] == 0))))
1233 lose = 1;
1234 /* Replace multiple slashes with a single one, except
1235 leave leading "//" alone. */
1236 else if (IS_DIRECTORY_SEP (p[0])
1237 && IS_DIRECTORY_SEP (p[1])
1238 && (p != nm || IS_DIRECTORY_SEP (p[2])))
1239 lose = 1;
1240 p++;
1241 }
1242 if (!lose)
1243 {
1244 #ifdef DOS_NT
1245 /* Make sure directories are all separated with /, but
1246 avoid allocation of a new string when not required. */
1247 dostounix_filename (nm);
1248 #ifdef WINDOWSNT
1249 if (IS_DIRECTORY_SEP (nm[1]))
1250 {
1251 if (strcmp (nm, SSDATA (name)) != 0)
1252 name = make_specified_string (nm, -1, nmlim - nm, multibyte);
1253 }
1254 else
1255 #endif
1256 /* Drive must be set, so this is okay. */
1257 if (strcmp (nm - 2, SSDATA (name)) != 0)
1258 {
1259 name = make_specified_string (nm, -1, p - nm, multibyte);
1260 char temp[] = { DRIVE_LETTER (drive), ':', 0 };
1261 AUTO_STRING_WITH_LEN (drive_prefix, temp, 2);
1262 name = concat2 (drive_prefix, name);
1263 }
1264 #ifdef WINDOWSNT
1265 if (!NILP (Vw32_downcase_file_names))
1266 name = Fdowncase (name);
1267 #endif
1268 #else /* not DOS_NT */
1269 if (strcmp (nm, SSDATA (name)) != 0)
1270 name = make_specified_string (nm, -1, nmlim - nm, multibyte);
1271 #endif /* not DOS_NT */
1272 SAFE_FREE ();
1273 return name;
1274 }
1275 }
1276
1277 /* At this point, nm might or might not be an absolute file name. We
1278 need to expand ~ or ~user if present, otherwise prefix nm with
1279 default_directory if nm is not absolute, and finally collapse /./
1280 and /foo/../ sequences.
1281
1282 We set newdir to be the appropriate prefix if one is needed:
1283 - the relevant user directory if nm starts with ~ or ~user
1284 - the specified drive's working dir (DOS/NT only) if nm does not
1285 start with /
1286 - the value of default_directory.
1287
1288 Note that these prefixes are not guaranteed to be absolute (except
1289 for the working dir of a drive). Therefore, to ensure we always
1290 return an absolute name, if the final prefix is not absolute we
1291 append it to the current working directory. */
1292
1293 newdir = newdirlim = 0;
1294
1295 if (nm[0] == '~' /* prefix ~ */
1296 #ifdef DOS_NT
1297 && !is_escaped /* don't expand ~ in escaped file names */
1298 #endif
1299 )
1300 {
1301 if (IS_DIRECTORY_SEP (nm[1])
1302 || nm[1] == 0) /* ~ by itself */
1303 {
1304 Lisp_Object tem;
1305
1306 newdir = get_homedir ();
1307 nm++;
1308 tem = build_string (newdir);
1309 newdirlim = newdir + SBYTES (tem);
1310 /* get_homedir may return a unibyte string, which will bite us
1311 if we expect the directory to be multibyte. */
1312 if (multibyte && !STRING_MULTIBYTE (tem))
1313 {
1314 hdir = DECODE_FILE (tem);
1315 newdir = SSDATA (hdir);
1316 newdirlim = newdir + SBYTES (hdir);
1317 }
1318 else if (!multibyte && STRING_MULTIBYTE (tem))
1319 multibyte = 1;
1320 #ifdef DOS_NT
1321 collapse_newdir = false;
1322 #endif
1323 }
1324 else /* ~user/filename */
1325 {
1326 char *nmhome = user_homedir (nm + 1);
1327 if (nmhome)
1328 {
1329 ptrdiff_t nmhomelen = strlen (nmhome);
1330 newdir = nmhome;
1331 newdirlim = newdir + nmhomelen;
1332 if (multibyte)
1333 {
1334 AUTO_STRING_WITH_LEN (lisp_nmhome, nmhome, nmhomelen);
1335 hdir = DECODE_FILE (lisp_nmhome);
1336 newdir = SSDATA (hdir);
1337 newdirlim = newdir + SBYTES (hdir);
1338 }
1339
1340 while (*++nm && !IS_DIRECTORY_SEP (*nm))
1341 continue;
1342 #ifdef DOS_NT
1343 collapse_newdir = false;
1344 #endif
1345 }
1346
1347 /* If we don't find a user of that name, leave the name
1348 unchanged. */
1349 }
1350 }
1351
1352 #ifdef DOS_NT
1353 /* On DOS and Windows, nm is absolute if a drive name was specified;
1354 use the drive's current directory as the prefix if needed. */
1355 if (!newdir && drive)
1356 {
1357 /* Get default directory if needed to make nm absolute. */
1358 char *adir = NULL;
1359 if (!IS_DIRECTORY_SEP (nm[0]))
1360 {
1361 adir = alloca (MAXPATHLEN + 1);
1362 if (!getdefdir (c_toupper (drive) - 'A' + 1, adir))
1363 adir = NULL;
1364 else if (multibyte)
1365 {
1366 Lisp_Object tem = build_string (adir);
1367
1368 tem = DECODE_FILE (tem);
1369 newdirlim = adir + SBYTES (tem);
1370 memcpy (adir, SSDATA (tem), SBYTES (tem) + 1);
1371 }
1372 else
1373 newdirlim = adir + strlen (adir);
1374 }
1375 if (!adir)
1376 {
1377 /* Either nm starts with /, or drive isn't mounted. */
1378 adir = alloca (4);
1379 adir[0] = DRIVE_LETTER (drive);
1380 adir[1] = ':';
1381 adir[2] = '/';
1382 adir[3] = 0;
1383 newdirlim = adir + 3;
1384 }
1385 newdir = adir;
1386 }
1387 #endif /* DOS_NT */
1388
1389 /* Finally, if no prefix has been specified and nm is not absolute,
1390 then it must be expanded relative to default_directory. */
1391
1392 if (1
1393 #ifndef DOS_NT
1394 /* /... alone is not absolute on DOS and Windows. */
1395 && !IS_DIRECTORY_SEP (nm[0])
1396 #endif
1397 #ifdef WINDOWSNT
1398 && !(IS_DIRECTORY_SEP (nm[0]) && IS_DIRECTORY_SEP (nm[1])
1399 && !IS_DIRECTORY_SEP (nm[2]))
1400 #endif
1401 && !newdir)
1402 {
1403 newdir = SSDATA (default_directory);
1404 newdirlim = newdir + SBYTES (default_directory);
1405 #ifdef DOS_NT
1406 /* Note if special escape prefix is present, but remove for now. */
1407 if (newdir[0] == '/' && newdir[1] == ':')
1408 {
1409 is_escaped = 1;
1410 newdir += 2;
1411 }
1412 #endif
1413 }
1414
1415 #ifdef DOS_NT
1416 if (newdir)
1417 {
1418 /* First ensure newdir is an absolute name. */
1419 if (
1420 /* Detect MSDOS file names with drive specifiers. */
1421 ! (IS_DRIVE (newdir[0])
1422 && IS_DEVICE_SEP (newdir[1]) && IS_DIRECTORY_SEP (newdir[2]))
1423 #ifdef WINDOWSNT
1424 /* Detect Windows file names in UNC format. */
1425 && ! (IS_DIRECTORY_SEP (newdir[0]) && IS_DIRECTORY_SEP (newdir[1])
1426 && !IS_DIRECTORY_SEP (newdir[2]))
1427 #endif
1428 )
1429 {
1430 /* Effectively, let newdir be (expand-file-name newdir cwd).
1431 Because of the admonition against calling expand-file-name
1432 when we have pointers into lisp strings, we accomplish this
1433 indirectly by prepending newdir to nm if necessary, and using
1434 cwd (or the wd of newdir's drive) as the new newdir. */
1435 char *adir;
1436 #ifdef WINDOWSNT
1437 const int adir_size = MAX_UTF8_PATH;
1438 #else
1439 const int adir_size = MAXPATHLEN + 1;
1440 #endif
1441
1442 if (IS_DRIVE (newdir[0]) && IS_DEVICE_SEP (newdir[1]))
1443 {
1444 drive = (unsigned char) newdir[0];
1445 newdir += 2;
1446 }
1447 if (!IS_DIRECTORY_SEP (nm[0]))
1448 {
1449 ptrdiff_t nmlen = nmlim - nm;
1450 ptrdiff_t newdirlen = newdirlim - newdir;
1451 char *tmp = alloca (newdirlen + file_name_as_directory_slop
1452 + nmlen + 1);
1453 ptrdiff_t dlen = file_name_as_directory (tmp, newdir, newdirlen,
1454 multibyte);
1455 memcpy (tmp + dlen, nm, nmlen + 1);
1456 nm = tmp;
1457 nmlim = nm + dlen + nmlen;
1458 }
1459 adir = alloca (adir_size);
1460 if (drive)
1461 {
1462 if (!getdefdir (c_toupper (drive) - 'A' + 1, adir))
1463 strcpy (adir, "/");
1464 }
1465 else
1466 getcwd (adir, adir_size);
1467 if (multibyte)
1468 {
1469 Lisp_Object tem = build_string (adir);
1470
1471 tem = DECODE_FILE (tem);
1472 newdirlim = adir + SBYTES (tem);
1473 memcpy (adir, SSDATA (tem), SBYTES (tem) + 1);
1474 }
1475 else
1476 newdirlim = adir + strlen (adir);
1477 newdir = adir;
1478 }
1479
1480 /* Strip off drive name from prefix, if present. */
1481 if (IS_DRIVE (newdir[0]) && IS_DEVICE_SEP (newdir[1]))
1482 {
1483 drive = newdir[0];
1484 newdir += 2;
1485 }
1486
1487 /* Keep only a prefix from newdir if nm starts with slash
1488 (//server/share for UNC, nothing otherwise). */
1489 if (IS_DIRECTORY_SEP (nm[0]) && collapse_newdir)
1490 {
1491 #ifdef WINDOWSNT
1492 if (IS_DIRECTORY_SEP (newdir[0]) && IS_DIRECTORY_SEP (newdir[1])
1493 && !IS_DIRECTORY_SEP (newdir[2]))
1494 {
1495 char *adir = strcpy (alloca (newdirlim - newdir + 1), newdir);
1496 char *p = adir + 2;
1497 while (*p && !IS_DIRECTORY_SEP (*p)) p++;
1498 p++;
1499 while (*p && !IS_DIRECTORY_SEP (*p)) p++;
1500 *p = 0;
1501 newdir = adir;
1502 newdirlim = newdir + strlen (adir);
1503 }
1504 else
1505 #endif
1506 newdir = newdirlim = "";
1507 }
1508 }
1509 #endif /* DOS_NT */
1510
1511 /* Ignore any slash at the end of newdir, unless newdir is
1512 just "/" or "//". */
1513 length = newdirlim - newdir;
1514 while (length > 1 && IS_DIRECTORY_SEP (newdir[length - 1])
1515 && ! (length == 2 && IS_DIRECTORY_SEP (newdir[0])))
1516 length--;
1517
1518 /* Now concatenate the directory and name to new space in the stack frame. */
1519 tlen = length + file_name_as_directory_slop + (nmlim - nm) + 1;
1520 eassert (tlen >= file_name_as_directory_slop + 1);
1521 #ifdef DOS_NT
1522 /* Reserve space for drive specifier and escape prefix, since either
1523 or both may need to be inserted. (The Microsoft x86 compiler
1524 produces incorrect code if the following two lines are combined.) */
1525 target = alloca (tlen + 4);
1526 target += 4;
1527 #else /* not DOS_NT */
1528 target = SAFE_ALLOCA (tlen);
1529 #endif /* not DOS_NT */
1530 *target = 0;
1531 nbytes = 0;
1532
1533 if (newdir)
1534 {
1535 if (nm[0] == 0 || IS_DIRECTORY_SEP (nm[0]))
1536 {
1537 #ifdef DOS_NT
1538 /* If newdir is effectively "C:/", then the drive letter will have
1539 been stripped and newdir will be "/". Concatenating with an
1540 absolute directory in nm produces "//", which will then be
1541 incorrectly treated as a network share. Ignore newdir in
1542 this case (keeping the drive letter). */
1543 if (!(drive && nm[0] && IS_DIRECTORY_SEP (newdir[0])
1544 && newdir[1] == '\0'))
1545 #endif
1546 {
1547 memcpy (target, newdir, length);
1548 target[length] = 0;
1549 nbytes = length;
1550 }
1551 }
1552 else
1553 nbytes = file_name_as_directory (target, newdir, length, multibyte);
1554 }
1555
1556 memcpy (target + nbytes, nm, nmlim - nm + 1);
1557
1558 /* Now canonicalize by removing `//', `/.' and `/foo/..' if they
1559 appear. */
1560 {
1561 char *p = target;
1562 char *o = target;
1563
1564 while (*p)
1565 {
1566 if (!IS_DIRECTORY_SEP (*p))
1567 {
1568 *o++ = *p++;
1569 }
1570 else if (p[1] == '.'
1571 && (IS_DIRECTORY_SEP (p[2])
1572 || p[2] == 0))
1573 {
1574 /* If "/." is the entire filename, keep the "/". Otherwise,
1575 just delete the whole "/.". */
1576 if (o == target && p[2] == '\0')
1577 *o++ = *p;
1578 p += 2;
1579 }
1580 else if (p[1] == '.' && p[2] == '.'
1581 /* `/../' is the "superroot" on certain file systems.
1582 Turned off on DOS_NT systems because they have no
1583 "superroot" and because this causes us to produce
1584 file names like "d:/../foo" which fail file-related
1585 functions of the underlying OS. (To reproduce, try a
1586 long series of "../../" in default_directory, longer
1587 than the number of levels from the root.) */
1588 #ifndef DOS_NT
1589 && o != target
1590 #endif
1591 && (IS_DIRECTORY_SEP (p[3]) || p[3] == 0))
1592 {
1593 #ifdef WINDOWSNT
1594 char *prev_o = o;
1595 #endif
1596 while (o != target && (--o, !IS_DIRECTORY_SEP (*o)))
1597 continue;
1598 #ifdef WINDOWSNT
1599 /* Don't go below server level in UNC filenames. */
1600 if (o == target + 1 && IS_DIRECTORY_SEP (*o)
1601 && IS_DIRECTORY_SEP (*target))
1602 o = prev_o;
1603 else
1604 #endif
1605 /* Keep initial / only if this is the whole name. */
1606 if (o == target && IS_ANY_SEP (*o) && p[3] == 0)
1607 ++o;
1608 p += 3;
1609 }
1610 else if (IS_DIRECTORY_SEP (p[1])
1611 && (p != target || IS_DIRECTORY_SEP (p[2])))
1612 /* Collapse multiple "/", except leave leading "//" alone. */
1613 p++;
1614 else
1615 {
1616 *o++ = *p++;
1617 }
1618 }
1619
1620 #ifdef DOS_NT
1621 /* At last, set drive name. */
1622 #ifdef WINDOWSNT
1623 /* Except for network file name. */
1624 if (!(IS_DIRECTORY_SEP (target[0]) && IS_DIRECTORY_SEP (target[1])))
1625 #endif /* WINDOWSNT */
1626 {
1627 if (!drive) emacs_abort ();
1628 target -= 2;
1629 target[0] = DRIVE_LETTER (drive);
1630 target[1] = ':';
1631 }
1632 /* Reinsert the escape prefix if required. */
1633 if (is_escaped)
1634 {
1635 target -= 2;
1636 target[0] = '/';
1637 target[1] = ':';
1638 }
1639 result = make_specified_string (target, -1, o - target, multibyte);
1640 dostounix_filename (SSDATA (result));
1641 #ifdef WINDOWSNT
1642 if (!NILP (Vw32_downcase_file_names))
1643 result = Fdowncase (result);
1644 #endif
1645 #else /* !DOS_NT */
1646 result = make_specified_string (target, -1, o - target, multibyte);
1647 #endif /* !DOS_NT */
1648 }
1649
1650 /* Again look to see if the file name has special constructs in it
1651 and perhaps call the corresponding file name handler. This is needed
1652 for filenames such as "/foo/../user@host:/bar/../baz". Expanding
1653 the ".." component gives us "/user@host:/bar/../baz" which needs
1654 to be expanded again. */
1655 handler = Ffind_file_name_handler (result, Qexpand_file_name);
1656 if (!NILP (handler))
1657 {
1658 handled_name = call3 (handler, Qexpand_file_name,
1659 result, default_directory);
1660 if (! STRINGP (handled_name))
1661 error ("Invalid handler in `file-name-handler-alist'");
1662 result = handled_name;
1663 }
1664
1665 SAFE_FREE ();
1666 return result;
1667 }
1668
1669 #if 0
1670 /* PLEASE DO NOT DELETE THIS COMMENTED-OUT VERSION!
1671 This is the old version of expand-file-name, before it was thoroughly
1672 rewritten for Emacs 10.31. We leave this version here commented-out,
1673 because the code is very complex and likely to have subtle bugs. If
1674 bugs _are_ found, it might be of interest to look at the old code and
1675 see what did it do in the relevant situation.
1676
1677 Don't remove this code: it's true that it will be accessible
1678 from the repository, but a few years from deletion, people will
1679 forget it is there. */
1680
1681 /* Changed this DEFUN to a DEAFUN, so as not to confuse `make-docfile'. */
1682 DEAFUN ("expand-file-name", Fexpand_file_name, Sexpand_file_name, 1, 2, 0,
1683 "Convert FILENAME to absolute, and canonicalize it.\n\
1684 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
1685 \(does not start with slash); if DEFAULT is nil or missing,\n\
1686 the current buffer's value of default-directory is used.\n\
1687 Filenames containing `.' or `..' as components are simplified;\n\
1688 initial `~/' expands to your home directory.\n\
1689 See also the function `substitute-in-file-name'.")
1690 (name, defalt)
1691 Lisp_Object name, defalt;
1692 {
1693 unsigned char *nm;
1694
1695 register unsigned char *newdir, *p, *o;
1696 ptrdiff_t tlen;
1697 unsigned char *target;
1698 struct passwd *pw;
1699
1700 CHECK_STRING (name);
1701 nm = SDATA (name);
1702
1703 /* If nm is absolute, flush ...// and detect /./ and /../.
1704 If no /./ or /../ we can return right away. */
1705 if (nm[0] == '/')
1706 {
1707 bool lose = 0;
1708 p = nm;
1709 while (*p)
1710 {
1711 if (p[0] == '/' && p[1] == '/')
1712 nm = p + 1;
1713 if (p[0] == '/' && p[1] == '~')
1714 nm = p + 1, lose = 1;
1715 if (p[0] == '/' && p[1] == '.'
1716 && (p[2] == '/' || p[2] == 0
1717 || (p[2] == '.' && (p[3] == '/' || p[3] == 0))))
1718 lose = 1;
1719 p++;
1720 }
1721 if (!lose)
1722 {
1723 if (nm == SDATA (name))
1724 return name;
1725 return build_string (nm);
1726 }
1727 }
1728
1729 /* Now determine directory to start with and put it in NEWDIR. */
1730
1731 newdir = 0;
1732
1733 if (nm[0] == '~') /* prefix ~ */
1734 if (nm[1] == '/' || nm[1] == 0)/* ~/filename */
1735 {
1736 if (!(newdir = (unsigned char *) egetenv ("HOME")))
1737 newdir = (unsigned char *) "";
1738 nm++;
1739 }
1740 else /* ~user/filename */
1741 {
1742 /* Get past ~ to user. */
1743 unsigned char *user = nm + 1;
1744 /* Find end of name. */
1745 unsigned char *ptr = (unsigned char *) strchr (user, '/');
1746 ptrdiff_t len = ptr ? ptr - user : strlen (user);
1747 /* Copy the user name into temp storage. */
1748 o = alloca (len + 1);
1749 memcpy (o, user, len);
1750 o[len] = 0;
1751
1752 /* Look up the user name. */
1753 block_input ();
1754 pw = (struct passwd *) getpwnam (o + 1);
1755 unblock_input ();
1756 if (!pw)
1757 error ("\"%s\" isn't a registered user", o + 1);
1758
1759 newdir = (unsigned char *) pw->pw_dir;
1760
1761 /* Discard the user name from NM. */
1762 nm += len;
1763 }
1764
1765 if (nm[0] != '/' && !newdir)
1766 {
1767 if (NILP (defalt))
1768 defalt = current_buffer->directory;
1769 CHECK_STRING (defalt);
1770 newdir = SDATA (defalt);
1771 }
1772
1773 /* Now concatenate the directory and name to new space in the stack frame. */
1774
1775 tlen = (newdir ? strlen (newdir) + 1 : 0) + strlen (nm) + 1;
1776 target = alloca (tlen);
1777 *target = 0;
1778
1779 if (newdir)
1780 {
1781 if (nm[0] == 0 || nm[0] == '/')
1782 strcpy (target, newdir);
1783 else
1784 file_name_as_directory (target, newdir);
1785 }
1786
1787 strcat (target, nm);
1788
1789 /* Now canonicalize by removing /. and /foo/.. if they appear. */
1790
1791 p = target;
1792 o = target;
1793
1794 while (*p)
1795 {
1796 if (*p != '/')
1797 {
1798 *o++ = *p++;
1799 }
1800 else if (!strncmp (p, "//", 2)
1801 )
1802 {
1803 o = target;
1804 p++;
1805 }
1806 else if (p[0] == '/' && p[1] == '.'
1807 && (p[2] == '/' || p[2] == 0))
1808 p += 2;
1809 else if (!strncmp (p, "/..", 3)
1810 /* `/../' is the "superroot" on certain file systems. */
1811 && o != target
1812 && (p[3] == '/' || p[3] == 0))
1813 {
1814 while (o != target && *--o != '/')
1815 ;
1816 if (o == target && *o == '/')
1817 ++o;
1818 p += 3;
1819 }
1820 else
1821 {
1822 *o++ = *p++;
1823 }
1824 }
1825
1826 return make_string (target, o - target);
1827 }
1828 #endif
1829
1830 /* Put into BUF the concatenation of DIR and FILE, with an intervening
1831 directory separator if needed. Return a pointer to the null byte
1832 at the end of the concatenated string. */
1833 char *
splice_dir_file(char * buf,char const * dir,char const * file)1834 splice_dir_file (char *buf, char const *dir, char const *file)
1835 {
1836 char *e = stpcpy (buf, dir);
1837 *e = DIRECTORY_SEP;
1838 e += ! (buf < e && IS_DIRECTORY_SEP (e[-1]));
1839 return stpcpy (e, file);
1840 }
1841
1842 /* Get the home directory, an absolute file name. Return the empty
1843 string on failure. The returned value does not survive garbage
1844 collection, calls to this function, or calls to the getpwnam class
1845 of functions. */
1846 char const *
get_homedir(void)1847 get_homedir (void)
1848 {
1849 char const *home = egetenv ("HOME");
1850
1851 #ifdef WINDOWSNT
1852 /* getpw* functions return UTF-8 encoded file names, whereas egetenv
1853 returns strings in locale encoding, so we need to convert for
1854 consistency. */
1855 static char homedir_utf8[MAX_UTF8_PATH];
1856 if (home)
1857 {
1858 filename_from_ansi (home, homedir_utf8);
1859 home = homedir_utf8;
1860 }
1861 #endif
1862
1863 if (!home)
1864 {
1865 static char const *userenv[] = {"LOGNAME", "USER"};
1866 struct passwd *pw = NULL;
1867 for (int i = 0; i < ARRAYELTS (userenv); i++)
1868 {
1869 char *user = egetenv (userenv[i]);
1870 if (user)
1871 {
1872 pw = getpwnam (user);
1873 if (pw)
1874 break;
1875 }
1876 }
1877 if (!pw)
1878 pw = getpwuid (getuid ());
1879 if (pw)
1880 home = pw->pw_dir;
1881 if (!home)
1882 return "";
1883 }
1884 #ifdef DOS_NT
1885 /* If home is a drive-relative directory, expand it. */
1886 if (IS_DRIVE (*home)
1887 && IS_DEVICE_SEP (home[1])
1888 && !IS_DIRECTORY_SEP (home[2]))
1889 {
1890 # ifdef WINDOWSNT
1891 static char hdir[MAX_UTF8_PATH];
1892 # else
1893 static char hdir[MAXPATHLEN];
1894 # endif
1895 if (!getdefdir (c_toupper (*home) - 'A' + 1, hdir))
1896 {
1897 hdir[0] = c_toupper (*home);
1898 hdir[1] = ':';
1899 hdir[2] = '/';
1900 hdir[3] = '\0';
1901 }
1902 if (home[2])
1903 {
1904 size_t homelen = strlen (hdir);
1905 if (!IS_DIRECTORY_SEP (hdir[homelen - 1]))
1906 strcat (hdir, "/");
1907 strcat (hdir, home + 2);
1908 }
1909 home = hdir;
1910 }
1911 #endif
1912 if (IS_ABSOLUTE_FILE_NAME (home))
1913 return home;
1914 if (!emacs_wd)
1915 error ("$HOME is relative to unknown directory");
1916 static char *ahome;
1917 static ptrdiff_t ahomesize;
1918 ptrdiff_t ahomelenbound = strlen (emacs_wd) + 1 + strlen (home) + 1;
1919 if (ahomesize <= ahomelenbound)
1920 ahome = xpalloc (ahome, &ahomesize, ahomelenbound + 1 - ahomesize, -1, 1);
1921 splice_dir_file (ahome, emacs_wd, home);
1922 return ahome;
1923 }
1924
1925 /* If a directory separator followed by an absolute file name (e.g.,
1926 "//foo", "/~", "/~someuser") appears in NM, return the address of
1927 the absolute file name. Otherwise return NULL. ENDP is the
1928 address of the null byte at the end of NM. */
1929 static char *
search_embedded_absfilename(char * nm,char * endp)1930 search_embedded_absfilename (char *nm, char *endp)
1931 {
1932 char *p = nm + 1;
1933 #ifdef DOUBLE_SLASH_IS_DISTINCT_ROOT
1934 p += (IS_DIRECTORY_SEP (p[-1]) && IS_DIRECTORY_SEP (p[0])
1935 && !IS_DIRECTORY_SEP (p[1]));
1936 #endif
1937 for (; p < endp; p++)
1938 if (IS_DIRECTORY_SEP (p[-1]) && file_name_absolute_p (p))
1939 return p;
1940 return NULL;
1941 }
1942
1943 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name,
1944 Ssubstitute_in_file_name, 1, 1, 0,
1945 doc: /* Substitute environment variables referred to in FILENAME.
1946 `$FOO' where FOO is an environment variable name means to substitute
1947 the value of that variable. The variable name should be terminated
1948 with a character not a letter, digit or underscore; otherwise, enclose
1949 the entire variable name in braces.
1950
1951 If FOO is not defined in the environment, `$FOO' is left unchanged in
1952 the value of this function.
1953
1954 If `/~' appears, all of FILENAME through that `/' is discarded.
1955 If `//' appears, everything up to and including the first of
1956 those `/' is discarded. */)
1957 (Lisp_Object filename)
1958 {
1959 char *nm, *p, *x, *endp;
1960 bool substituted = false;
1961 bool multibyte;
1962 char *xnm;
1963 Lisp_Object handler;
1964
1965 CHECK_STRING (filename);
1966
1967 multibyte = STRING_MULTIBYTE (filename);
1968
1969 /* If the file name has special constructs in it,
1970 call the corresponding file name handler. */
1971 handler = Ffind_file_name_handler (filename, Qsubstitute_in_file_name);
1972 if (!NILP (handler))
1973 {
1974 Lisp_Object handled_name = call2 (handler, Qsubstitute_in_file_name,
1975 filename);
1976 if (STRINGP (handled_name))
1977 return handled_name;
1978 error ("Invalid handler in `file-name-handler-alist'");
1979 }
1980
1981 /* Always work on a copy of the string, in case GC happens during
1982 decode of environment variables, causing the original Lisp_String
1983 data to be relocated. */
1984 USE_SAFE_ALLOCA;
1985 SAFE_ALLOCA_STRING (nm, filename);
1986
1987 #ifdef DOS_NT
1988 dostounix_filename (nm);
1989 substituted = (memcmp (nm, SDATA (filename), SBYTES (filename)) != 0);
1990 #endif
1991 endp = nm + SBYTES (filename);
1992
1993 /* If /~ or // appears, discard everything through first slash. */
1994 p = search_embedded_absfilename (nm, endp);
1995 if (p)
1996 /* Start over with the new string, so we check the file-name-handler
1997 again. Important with filenames like "/home/foo//:/hello///there"
1998 which would substitute to "/:/hello///there" rather than "/there". */
1999 {
2000 Lisp_Object result
2001 = (Fsubstitute_in_file_name
2002 (make_specified_string (p, -1, endp - p, multibyte)));
2003 SAFE_FREE ();
2004 return result;
2005 }
2006
2007 /* See if any variables are substituted into the string. */
2008
2009 if (!NILP (Ffboundp (Qsubstitute_env_in_file_name)))
2010 {
2011 Lisp_Object name
2012 = (!substituted ? filename
2013 : make_specified_string (nm, -1, endp - nm, multibyte));
2014 Lisp_Object tmp = call1 (Qsubstitute_env_in_file_name, name);
2015 CHECK_STRING (tmp);
2016 if (!EQ (tmp, name))
2017 substituted = true;
2018 filename = tmp;
2019 }
2020
2021 if (!substituted)
2022 {
2023 #ifdef WINDOWSNT
2024 if (!NILP (Vw32_downcase_file_names))
2025 filename = Fdowncase (filename);
2026 #endif
2027 SAFE_FREE ();
2028 return filename;
2029 }
2030
2031 xnm = SSDATA (filename);
2032 x = xnm + SBYTES (filename);
2033
2034 /* If /~ or // appears, discard everything through first slash. */
2035 while ((p = search_embedded_absfilename (xnm, x)) != NULL)
2036 /* This time we do not start over because we've already expanded envvars
2037 and replaced $$ with $. Maybe we should start over as well, but we'd
2038 need to quote some $ to $$ first. */
2039 xnm = p;
2040
2041 #ifdef WINDOWSNT
2042 if (!NILP (Vw32_downcase_file_names))
2043 {
2044 Lisp_Object xname = make_specified_string (xnm, -1, x - xnm, multibyte);
2045
2046 filename = Fdowncase (xname);
2047 }
2048 else
2049 #endif
2050 if (xnm != SSDATA (filename))
2051 filename = make_specified_string (xnm, -1, x - xnm, multibyte);
2052 SAFE_FREE ();
2053 return filename;
2054 }
2055
2056 /* A slightly faster and more convenient way to get
2057 (directory-file-name (expand-file-name FOO)). */
2058
2059 Lisp_Object
expand_and_dir_to_file(Lisp_Object filename)2060 expand_and_dir_to_file (Lisp_Object filename)
2061 {
2062 Lisp_Object absname = Fexpand_file_name (filename, Qnil);
2063
2064 /* Remove final slash, if any (unless this is the root dir).
2065 stat behaves differently depending! */
2066 if (SCHARS (absname) > 1
2067 && IS_DIRECTORY_SEP (SREF (absname, SBYTES (absname) - 1))
2068 && !IS_DEVICE_SEP (SREF (absname, SBYTES (absname) - 2)))
2069 /* We cannot take shortcuts; they might be wrong for magic file names. */
2070 absname = Fdirectory_file_name (absname);
2071 return absname;
2072 }
2073
2074 /* Signal an error if the file ABSNAME already exists.
2075 If KNOWN_TO_EXIST, the file is known to exist.
2076 QUERYSTRING is a name for the action that is being considered
2077 to alter the file.
2078 If INTERACTIVE, ask the user whether to proceed,
2079 and bypass the error if the user says to go ahead.
2080 If QUICK, ask for y or n, not yes or no. */
2081
2082 static void
barf_or_query_if_file_exists(Lisp_Object absname,bool known_to_exist,const char * querystring,bool interactive,bool quick)2083 barf_or_query_if_file_exists (Lisp_Object absname, bool known_to_exist,
2084 const char *querystring, bool interactive,
2085 bool quick)
2086 {
2087 Lisp_Object tem, encoded_filename;
2088 struct stat statbuf;
2089
2090 encoded_filename = ENCODE_FILE (absname);
2091
2092 if (! known_to_exist
2093 && (emacs_fstatat (AT_FDCWD, SSDATA (encoded_filename),
2094 &statbuf, AT_SYMLINK_NOFOLLOW)
2095 == 0))
2096 {
2097 if (S_ISDIR (statbuf.st_mode))
2098 xsignal2 (Qfile_error,
2099 build_string ("File is a directory"), absname);
2100 known_to_exist = true;
2101 }
2102
2103 if (known_to_exist)
2104 {
2105 if (! interactive)
2106 xsignal2 (Qfile_already_exists,
2107 build_string ("File already exists"), absname);
2108 AUTO_STRING (format, "File %s already exists; %s anyway? ");
2109 tem = CALLN (Fformat, format, absname, build_string (querystring));
2110 if (quick)
2111 tem = call1 (intern ("y-or-n-p"), tem);
2112 else
2113 tem = do_yes_or_no_p (tem);
2114 if (NILP (tem))
2115 xsignal2 (Qfile_already_exists,
2116 build_string ("File already exists"), absname);
2117 }
2118 }
2119
2120 #ifndef WINDOWSNT
2121 /* Copy data to DEST from SOURCE if possible. Return true if OK. */
2122 static bool
clone_file(int dest,int source)2123 clone_file (int dest, int source)
2124 {
2125 #ifdef FICLONE
2126 return ioctl (dest, FICLONE, source) == 0;
2127 #endif
2128 return false;
2129 }
2130 #endif
2131
2132 DEFUN ("copy-file", Fcopy_file, Scopy_file, 2, 6,
2133 "fCopy file: \nGCopy %s to file: \np\nP",
2134 doc: /* Copy FILE to NEWNAME. Both args must be strings.
2135 If NEWNAME is a directory name, copy FILE to a like-named file under
2136 NEWNAME. For NEWNAME to be recognized as a directory name, it should
2137 end in a slash.
2138
2139 This function always sets the file modes of the output file to match
2140 the input file.
2141
2142 The optional third argument OK-IF-ALREADY-EXISTS specifies what to do
2143 if file NEWNAME already exists. If OK-IF-ALREADY-EXISTS is nil,
2144 signal a `file-already-exists' error without overwriting. If
2145 OK-IF-ALREADY-EXISTS is an integer, request confirmation from the user
2146 about overwriting; this is what happens in interactive use with M-x.
2147 Any other value for OK-IF-ALREADY-EXISTS means to overwrite the
2148 existing file.
2149
2150 Fourth arg KEEP-TIME non-nil means give the output file the same
2151 last-modified time as the old one. (This works on only some systems.)
2152
2153 A prefix arg makes KEEP-TIME non-nil.
2154
2155 If PRESERVE-UID-GID is non-nil, try to transfer the uid and gid of
2156 FILE to NEWNAME.
2157
2158 If PRESERVE-PERMISSIONS is non-nil, copy permissions of FILE to NEWNAME;
2159 this includes the file modes, along with ACL entries and SELinux
2160 context if present. Otherwise, if NEWNAME is created its file
2161 permission bits are those of FILE, masked by the default file
2162 permissions. */)
2163 (Lisp_Object file, Lisp_Object newname, Lisp_Object ok_if_already_exists,
2164 Lisp_Object keep_time, Lisp_Object preserve_uid_gid,
2165 Lisp_Object preserve_permissions)
2166 {
2167 Lisp_Object handler;
2168 ptrdiff_t count = SPECPDL_INDEX ();
2169 Lisp_Object encoded_file, encoded_newname;
2170 #if HAVE_LIBSELINUX
2171 char *con;
2172 int conlength = 0;
2173 #endif
2174 #ifdef WINDOWSNT
2175 int result;
2176 #else
2177 bool already_exists = false;
2178 mode_t new_mask;
2179 int ifd, ofd;
2180 struct stat st;
2181 #endif
2182
2183 file = Fexpand_file_name (file, Qnil);
2184 newname = expand_cp_target (file, newname);
2185
2186 /* If the input file name has special constructs in it,
2187 call the corresponding file name handler. */
2188 handler = Ffind_file_name_handler (file, Qcopy_file);
2189 /* Likewise for output file name. */
2190 if (NILP (handler))
2191 handler = Ffind_file_name_handler (newname, Qcopy_file);
2192 if (!NILP (handler))
2193 return call7 (handler, Qcopy_file, file, newname,
2194 ok_if_already_exists, keep_time, preserve_uid_gid,
2195 preserve_permissions);
2196
2197 encoded_file = ENCODE_FILE (file);
2198 encoded_newname = ENCODE_FILE (newname);
2199
2200 #ifdef WINDOWSNT
2201 if (NILP (ok_if_already_exists)
2202 || FIXNUMP (ok_if_already_exists))
2203 barf_or_query_if_file_exists (newname, false, "copy to it",
2204 FIXNUMP (ok_if_already_exists), false);
2205
2206 result = w32_copy_file (SSDATA (encoded_file), SSDATA (encoded_newname),
2207 !NILP (keep_time), !NILP (preserve_uid_gid),
2208 !NILP (preserve_permissions));
2209 switch (result)
2210 {
2211 case -1:
2212 report_file_error ("Copying file", list2 (file, newname));
2213 case -2:
2214 report_file_error ("Copying permissions from", file);
2215 case -3:
2216 xsignal2 (Qfile_date_error,
2217 build_string ("Cannot set file date"), newname);
2218 case -4:
2219 report_file_error ("Copying permissions to", newname);
2220 }
2221 #else /* not WINDOWSNT */
2222 ifd = emacs_open (SSDATA (encoded_file), O_RDONLY, 0);
2223
2224 if (ifd < 0)
2225 report_file_error ("Opening input file", file);
2226
2227 record_unwind_protect_int (close_file_unwind, ifd);
2228
2229 if (fstat (ifd, &st) != 0)
2230 report_file_error ("Input file status", file);
2231
2232 if (!NILP (preserve_permissions))
2233 {
2234 #if HAVE_LIBSELINUX
2235 if (is_selinux_enabled ())
2236 {
2237 conlength = fgetfilecon (ifd, &con);
2238 if (conlength == -1)
2239 report_file_error ("Doing fgetfilecon", file);
2240 }
2241 #endif
2242 }
2243
2244 /* We can copy only regular files. */
2245 if (!S_ISREG (st.st_mode))
2246 report_file_errno ("Non-regular file", file,
2247 S_ISDIR (st.st_mode) ? EISDIR : EINVAL);
2248
2249 #ifndef MSDOS
2250 new_mask = st.st_mode & (!NILP (preserve_uid_gid) ? 0700 : 0777);
2251 #else
2252 new_mask = S_IREAD | S_IWRITE;
2253 #endif
2254
2255 ofd = emacs_open (SSDATA (encoded_newname), O_WRONLY | O_CREAT | O_EXCL,
2256 new_mask);
2257 if (ofd < 0 && errno == EEXIST)
2258 {
2259 if (NILP (ok_if_already_exists) || FIXNUMP (ok_if_already_exists))
2260 barf_or_query_if_file_exists (newname, true, "copy to it",
2261 FIXNUMP (ok_if_already_exists), false);
2262 already_exists = true;
2263 ofd = emacs_open (SSDATA (encoded_newname), O_WRONLY, 0);
2264 }
2265 if (ofd < 0)
2266 report_file_error ("Opening output file", newname);
2267
2268 record_unwind_protect_int (close_file_unwind, ofd);
2269
2270 off_t oldsize = 0, newsize;
2271
2272 if (already_exists)
2273 {
2274 struct stat out_st;
2275 if (fstat (ofd, &out_st) != 0)
2276 report_file_error ("Output file status", newname);
2277 if (st.st_dev == out_st.st_dev && st.st_ino == out_st.st_ino)
2278 report_file_errno ("Input and output files are the same",
2279 list2 (file, newname), 0);
2280 if (S_ISREG (out_st.st_mode))
2281 oldsize = out_st.st_size;
2282 }
2283
2284 maybe_quit ();
2285
2286 if (clone_file (ofd, ifd))
2287 newsize = st.st_size;
2288 else
2289 {
2290 off_t insize = st.st_size;
2291 ssize_t copied;
2292
2293 #ifndef MSDOS
2294 for (newsize = 0; newsize < insize; newsize += copied)
2295 {
2296 /* Copy at most COPY_MAX bytes at a time; this is min
2297 (PTRDIFF_MAX, SIZE_MAX) truncated to a value that is
2298 surely aligned well. */
2299 ssize_t ssize_max = TYPE_MAXIMUM (ssize_t);
2300 ptrdiff_t copy_max = min (ssize_max, SIZE_MAX) >> 30 << 30;
2301 off_t intail = insize - newsize;
2302 ptrdiff_t len = min (intail, copy_max);
2303 copied = copy_file_range (ifd, NULL, ofd, NULL, len, 0);
2304 if (copied <= 0)
2305 break;
2306 maybe_quit ();
2307 }
2308 #endif /* MSDOS */
2309
2310 /* Fall back on read+write if copy_file_range failed, or if the
2311 input is empty and so could be a /proc file. read+write will
2312 either succeed, or report an error more precisely than
2313 copy_file_range would. */
2314 if (newsize != insize || insize == 0)
2315 {
2316 char buf[MAX_ALLOCA];
2317 for (; (copied = emacs_read_quit (ifd, buf, sizeof buf));
2318 newsize += copied)
2319 {
2320 if (copied < 0)
2321 report_file_error ("Read error", file);
2322 if (emacs_write_quit (ofd, buf, copied) != copied)
2323 report_file_error ("Write error", newname);
2324 }
2325 }
2326 }
2327
2328 /* Truncate any existing output file after writing the data. This
2329 is more likely to work than truncation before writing, if the
2330 file system is out of space or the user is over disk quota. */
2331 if (newsize < oldsize && ftruncate (ofd, newsize) != 0)
2332 report_file_error ("Truncating output file", newname);
2333
2334 #ifndef MSDOS
2335 /* Preserve the original file permissions, and if requested, also its
2336 owner and group. */
2337 {
2338 mode_t preserved_permissions = st.st_mode & 07777;
2339 mode_t default_permissions = st.st_mode & 0777 & ~realmask;
2340 if (!NILP (preserve_uid_gid))
2341 {
2342 /* Attempt to change owner and group. If that doesn't work
2343 attempt to change just the group, as that is sometimes allowed.
2344 Adjust the mode mask to eliminate setuid or setgid bits
2345 or group permissions bits that are inappropriate if the
2346 owner or group are wrong. */
2347 if (fchown (ofd, st.st_uid, st.st_gid) != 0)
2348 {
2349 if (fchown (ofd, -1, st.st_gid) == 0)
2350 preserved_permissions &= ~04000;
2351 else
2352 {
2353 preserved_permissions &= ~06000;
2354
2355 /* Copy the other bits to the group bits, since the
2356 group is wrong. */
2357 preserved_permissions &= ~070;
2358 preserved_permissions |= (preserved_permissions & 7) << 3;
2359 default_permissions &= ~070;
2360 default_permissions |= (default_permissions & 7) << 3;
2361 }
2362 }
2363 }
2364
2365 switch (!NILP (preserve_permissions)
2366 ? qcopy_acl (SSDATA (encoded_file), ifd,
2367 SSDATA (encoded_newname), ofd,
2368 preserved_permissions)
2369 : (already_exists
2370 || (new_mask & ~realmask) == default_permissions)
2371 ? 0
2372 : fchmod (ofd, default_permissions))
2373 {
2374 case -2: report_file_error ("Copying permissions from", file);
2375 case -1: report_file_error ("Copying permissions to", newname);
2376 }
2377 }
2378 #endif /* not MSDOS */
2379
2380 #if HAVE_LIBSELINUX
2381 if (conlength > 0)
2382 {
2383 /* Set the modified context back to the file. */
2384 bool fail = fsetfilecon (ofd, con) != 0;
2385 /* See https://debbugs.gnu.org/11245 for ENOTSUP. */
2386 if (fail && errno != ENOTSUP)
2387 report_file_error ("Doing fsetfilecon", newname);
2388
2389 freecon (con);
2390 }
2391 #endif
2392
2393 if (!NILP (keep_time))
2394 {
2395 struct timespec ts[2];
2396 ts[0] = get_stat_atime (&st);
2397 ts[1] = get_stat_mtime (&st);
2398 if (futimens (ofd, ts) != 0)
2399 xsignal2 (Qfile_date_error,
2400 build_string ("Cannot set file date"), newname);
2401 }
2402
2403 if (emacs_close (ofd) < 0)
2404 report_file_error ("Write error", newname);
2405
2406 emacs_close (ifd);
2407
2408 #ifdef MSDOS
2409 /* In DJGPP v2.0 and later, fstat usually returns true file mode bits,
2410 and if it can't, it tells so. Otherwise, under MSDOS we usually
2411 get only the READ bit, which will make the copied file read-only,
2412 so it's better not to chmod at all. */
2413 if ((_djstat_flags & _STFAIL_WRITEBIT) == 0)
2414 chmod (SDATA (encoded_newname), st.st_mode & 07777);
2415 #endif /* MSDOS */
2416 #endif /* not WINDOWSNT */
2417
2418 /* Discard the unwind protects. */
2419 specpdl_ptr = specpdl + count;
2420
2421 return Qnil;
2422 }
2423
2424 DEFUN ("make-directory-internal", Fmake_directory_internal,
2425 Smake_directory_internal, 1, 1, 0,
2426 doc: /* Create a new directory named DIRECTORY. */)
2427 (Lisp_Object directory)
2428 {
2429 const char *dir;
2430 Lisp_Object handler;
2431 Lisp_Object encoded_dir;
2432
2433 CHECK_STRING (directory);
2434 directory = Fexpand_file_name (directory, Qnil);
2435
2436 handler = Ffind_file_name_handler (directory, Qmake_directory_internal);
2437 if (!NILP (handler))
2438 return call2 (handler, Qmake_directory_internal, directory);
2439
2440 encoded_dir = ENCODE_FILE (directory);
2441
2442 dir = SSDATA (encoded_dir);
2443
2444 if (mkdir (dir, 0777 & ~auto_saving_dir_umask) != 0)
2445 report_file_error ("Creating directory", directory);
2446
2447 return Qnil;
2448 }
2449
2450 DEFUN ("delete-directory-internal", Fdelete_directory_internal,
2451 Sdelete_directory_internal, 1, 1, 0,
2452 doc: /* Delete the directory named DIRECTORY. Does not follow symlinks. */)
2453 (Lisp_Object directory)
2454 {
2455 const char *dir;
2456 Lisp_Object encoded_dir;
2457
2458 CHECK_STRING (directory);
2459 directory = Fdirectory_file_name (Fexpand_file_name (directory, Qnil));
2460 encoded_dir = ENCODE_FILE (directory);
2461 dir = SSDATA (encoded_dir);
2462
2463 if (rmdir (dir) != 0)
2464 report_file_error ("Removing directory", directory);
2465
2466 return Qnil;
2467 }
2468
2469 DEFUN ("delete-file", Fdelete_file, Sdelete_file, 1, 2,
2470 "(list (read-file-name \
2471 (if (and delete-by-moving-to-trash (null current-prefix-arg)) \
2472 \"Move file to trash: \" \"Delete file: \") \
2473 nil default-directory (confirm-nonexistent-file-or-buffer)) \
2474 (null current-prefix-arg))",
2475 doc: /* Delete file named FILENAME. If it is a symlink, remove the symlink.
2476 If file has multiple names, it continues to exist with the other names.
2477 TRASH non-nil means to trash the file instead of deleting, provided
2478 `delete-by-moving-to-trash' is non-nil.
2479
2480 When called interactively, TRASH is t if no prefix argument is given.
2481 With a prefix argument, TRASH is nil. */)
2482 (Lisp_Object filename, Lisp_Object trash)
2483 {
2484 Lisp_Object handler;
2485 Lisp_Object encoded_file;
2486
2487 if (!NILP (Ffile_directory_p (filename))
2488 && NILP (Ffile_symlink_p (filename)))
2489 xsignal2 (Qfile_error,
2490 build_string ("Removing old name: is a directory"),
2491 filename);
2492 filename = Fexpand_file_name (filename, Qnil);
2493
2494 handler = Ffind_file_name_handler (filename, Qdelete_file);
2495 if (!NILP (handler))
2496 return call3 (handler, Qdelete_file, filename, trash);
2497
2498 if (delete_by_moving_to_trash && !NILP (trash))
2499 return call1 (Qmove_file_to_trash, filename);
2500
2501 encoded_file = ENCODE_FILE (filename);
2502
2503 if (unlink (SSDATA (encoded_file)) != 0 && errno != ENOENT)
2504 report_file_error ("Removing old name", filename);
2505 return Qnil;
2506 }
2507
2508 static Lisp_Object
internal_delete_file_1(Lisp_Object ignore)2509 internal_delete_file_1 (Lisp_Object ignore)
2510 {
2511 return Qt;
2512 }
2513
2514 /* Delete file FILENAME, returning true if successful.
2515 This ignores `delete-by-moving-to-trash'. */
2516
2517 bool
internal_delete_file(Lisp_Object filename)2518 internal_delete_file (Lisp_Object filename)
2519 {
2520 Lisp_Object tem;
2521
2522 tem = internal_condition_case_2 (Fdelete_file, filename, Qnil,
2523 Qt, internal_delete_file_1);
2524 return NILP (tem);
2525 }
2526
2527 /* Return -1 if FILE is a case-insensitive file name, 0 if not,
2528 and a positive errno value if the result cannot be determined. */
2529
2530 static int
file_name_case_insensitive_err(Lisp_Object file)2531 file_name_case_insensitive_err (Lisp_Object file)
2532 {
2533 /* Filesystems are case-sensitive on all supported systems except
2534 MS-Windows, MS-DOS, Cygwin, and macOS. They are always
2535 case-insensitive on the first two, but they may or may not be
2536 case-insensitive on Cygwin and macOS so do a runtime test on
2537 those two systems. If the test is not conclusive, assume
2538 case-insensitivity on Cygwin and case-sensitivity on macOS.
2539
2540 FIXME: Mounted filesystems on Posix hosts, like Samba shares or
2541 NFS-mounted Windows volumes, might be case-insensitive. Can we
2542 detect this?
2543
2544 Use pathconf with _PC_CASE_INSENSITIVE or _PC_CASE_SENSITIVE if
2545 those flags are available. As of this writing (2019-09-15),
2546 Cygwin is the only platform known to support the former (starting
2547 with Cygwin-2.6.1), and macOS is the only platform known to
2548 support the latter. */
2549
2550 #if defined _PC_CASE_INSENSITIVE || defined _PC_CASE_SENSITIVE
2551 char *filename = SSDATA (ENCODE_FILE (file));
2552 # ifdef _PC_CASE_INSENSITIVE
2553 long int res = pathconf (filename, _PC_CASE_INSENSITIVE);
2554 if (res >= 0)
2555 return - (res > 0);
2556 # else
2557 long int res = pathconf (filename, _PC_CASE_SENSITIVE);
2558 if (res >= 0)
2559 return - (res == 0);
2560 # endif
2561 if (errno != EINVAL)
2562 return errno;
2563 #endif
2564
2565 #if defined CYGWIN || defined DOS_NT
2566 return -1;
2567 #else
2568 return 0;
2569 #endif
2570 }
2571
2572 DEFUN ("file-name-case-insensitive-p", Ffile_name_case_insensitive_p,
2573 Sfile_name_case_insensitive_p, 1, 1, 0,
2574 doc: /* Return t if file FILENAME is on a case-insensitive filesystem.
2575 Return nil if FILENAME does not exist or is not on a case-insensitive
2576 filesystem, or if there was trouble determining whether the filesystem
2577 is case-insensitive. */)
2578 (Lisp_Object filename)
2579 {
2580 Lisp_Object handler;
2581
2582 CHECK_STRING (filename);
2583 filename = Fexpand_file_name (filename, Qnil);
2584
2585 /* If the file name has special constructs in it,
2586 call the corresponding file name handler. */
2587 handler = Ffind_file_name_handler (filename, Qfile_name_case_insensitive_p);
2588 if (!NILP (handler))
2589 return call2 (handler, Qfile_name_case_insensitive_p, filename);
2590
2591 /* If the file doesn't exist or there is trouble checking its
2592 filesystem, move up the filesystem tree until we reach an
2593 existing, trouble-free directory or the root. */
2594 while (true)
2595 {
2596 int err = file_name_case_insensitive_err (filename);
2597 if (err <= 0)
2598 return err < 0 ? Qt : Qnil;
2599 Lisp_Object parent = file_name_directory (filename);
2600 /* Avoid infinite loop if the root has trouble
2601 (impossible?). */
2602 if (!NILP (Fstring_equal (parent, filename)))
2603 return Qnil;
2604 filename = parent;
2605 }
2606 }
2607
2608 DEFUN ("rename-file", Frename_file, Srename_file, 2, 3,
2609 "fRename file: \nGRename %s to file: \np",
2610 doc: /* Rename FILE as NEWNAME. Both args must be strings.
2611 If file has names other than FILE, it continues to have those names.
2612 If NEWNAME is a directory name, rename FILE to a like-named file under
2613 NEWNAME. For NEWNAME to be recognized as a directory name, it should
2614 end in a slash.
2615
2616 Signal a `file-already-exists' error if a file NEWNAME already exists
2617 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
2618 An integer third arg means request confirmation if NEWNAME already exists.
2619 This is what happens in interactive use with M-x. */)
2620 (Lisp_Object file, Lisp_Object newname, Lisp_Object ok_if_already_exists)
2621 {
2622 Lisp_Object handler;
2623 Lisp_Object encoded_file, encoded_newname;
2624
2625 file = Fexpand_file_name (file, Qnil);
2626
2627 /* If the filesystem is case-insensitive and the file names are
2628 identical but for case, treat it as a change-case request, and do
2629 not worry whether NEWNAME exists or whether it is a directory, as
2630 it is already another name for FILE. */
2631 bool case_only_rename = false;
2632 #if defined CYGWIN || defined DOS_NT
2633 if (!NILP (Ffile_name_case_insensitive_p (file)))
2634 {
2635 newname = Fexpand_file_name (newname, Qnil);
2636 case_only_rename = !NILP (Fstring_equal (Fdowncase (file),
2637 Fdowncase (newname)));
2638 }
2639 #endif
2640
2641 if (!case_only_rename)
2642 newname = expand_cp_target (Fdirectory_file_name (file), newname);
2643
2644 /* If the file name has special constructs in it,
2645 call the corresponding file name handler. */
2646 handler = Ffind_file_name_handler (file, Qrename_file);
2647 if (NILP (handler))
2648 handler = Ffind_file_name_handler (newname, Qrename_file);
2649 if (!NILP (handler))
2650 return call4 (handler, Qrename_file,
2651 file, newname, ok_if_already_exists);
2652
2653 encoded_file = ENCODE_FILE (file);
2654 encoded_newname = ENCODE_FILE (newname);
2655
2656 bool plain_rename = (case_only_rename
2657 || (!NILP (ok_if_already_exists)
2658 && !FIXNUMP (ok_if_already_exists)));
2659 int rename_errno UNINIT;
2660 if (!plain_rename)
2661 {
2662 if (renameat_noreplace (AT_FDCWD, SSDATA (encoded_file),
2663 AT_FDCWD, SSDATA (encoded_newname))
2664 == 0)
2665 return Qnil;
2666
2667 rename_errno = errno;
2668 switch (rename_errno)
2669 {
2670 case EEXIST: case EINVAL: case ENOSYS:
2671 #if ENOSYS != ENOTSUP
2672 case ENOTSUP:
2673 #endif
2674 barf_or_query_if_file_exists (newname, rename_errno == EEXIST,
2675 "rename to it",
2676 FIXNUMP (ok_if_already_exists),
2677 false);
2678 plain_rename = true;
2679 break;
2680 }
2681 }
2682
2683 if (plain_rename)
2684 {
2685 if (rename (SSDATA (encoded_file), SSDATA (encoded_newname)) == 0)
2686 return Qnil;
2687 rename_errno = errno;
2688 /* Don't prompt again. */
2689 ok_if_already_exists = Qt;
2690 }
2691 else if (!NILP (ok_if_already_exists))
2692 ok_if_already_exists = Qt;
2693
2694 if (rename_errno != EXDEV)
2695 report_file_errno ("Renaming", list2 (file, newname), rename_errno);
2696
2697 struct stat file_st;
2698 bool dirp = !NILP (Fdirectory_name_p (file));
2699 if (!dirp)
2700 {
2701 if (emacs_fstatat (AT_FDCWD, SSDATA (encoded_file),
2702 &file_st, AT_SYMLINK_NOFOLLOW)
2703 != 0)
2704 report_file_error ("Renaming", list2 (file, newname));
2705 dirp = S_ISDIR (file_st.st_mode) != 0;
2706 }
2707 if (dirp)
2708 call4 (Qcopy_directory, file, newname, Qt, Qnil);
2709 else
2710 {
2711 Lisp_Object symlink_target
2712 = (S_ISLNK (file_st.st_mode)
2713 ? check_emacs_readlinkat (AT_FDCWD, file, SSDATA (encoded_file))
2714 : Qnil);
2715 if (!NILP (symlink_target))
2716 Fmake_symbolic_link (symlink_target, newname, ok_if_already_exists);
2717 else
2718 Fcopy_file (file, newname, ok_if_already_exists, Qt, Qt, Qt);
2719 }
2720
2721 ptrdiff_t count = SPECPDL_INDEX ();
2722 specbind (Qdelete_by_moving_to_trash, Qnil);
2723 if (dirp)
2724 call2 (Qdelete_directory, file, Qt);
2725 else
2726 Fdelete_file (file, Qnil);
2727 return unbind_to (count, Qnil);
2728 }
2729
2730 DEFUN ("add-name-to-file", Fadd_name_to_file, Sadd_name_to_file, 2, 3,
2731 "fAdd name to file: \nGName to add to %s: \np",
2732 doc: /* Give FILE additional name NEWNAME. Both args must be strings.
2733 If NEWNAME is a directory name, give FILE a like-named new name under
2734 NEWNAME.
2735
2736 Signal a `file-already-exists' error if a file NEWNAME already exists
2737 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
2738 An integer third arg means request confirmation if NEWNAME already exists.
2739 This is what happens in interactive use with M-x. */)
2740 (Lisp_Object file, Lisp_Object newname, Lisp_Object ok_if_already_exists)
2741 {
2742 Lisp_Object handler;
2743 Lisp_Object encoded_file, encoded_newname;
2744
2745 file = Fexpand_file_name (file, Qnil);
2746 newname = expand_cp_target (file, newname);
2747
2748 /* If the file name has special constructs in it,
2749 call the corresponding file name handler. */
2750 handler = Ffind_file_name_handler (file, Qadd_name_to_file);
2751 if (!NILP (handler))
2752 return call4 (handler, Qadd_name_to_file, file,
2753 newname, ok_if_already_exists);
2754
2755 /* If the new name has special constructs in it,
2756 call the corresponding file name handler. */
2757 handler = Ffind_file_name_handler (newname, Qadd_name_to_file);
2758 if (!NILP (handler))
2759 return call4 (handler, Qadd_name_to_file, file,
2760 newname, ok_if_already_exists);
2761
2762 encoded_file = ENCODE_FILE (file);
2763 encoded_newname = ENCODE_FILE (newname);
2764
2765 if (link (SSDATA (encoded_file), SSDATA (encoded_newname)) == 0)
2766 return Qnil;
2767
2768 if (errno == EEXIST)
2769 {
2770 if (NILP (ok_if_already_exists)
2771 || FIXNUMP (ok_if_already_exists))
2772 barf_or_query_if_file_exists (newname, true, "make it a new name",
2773 FIXNUMP (ok_if_already_exists), false);
2774 unlink (SSDATA (newname));
2775 if (link (SSDATA (encoded_file), SSDATA (encoded_newname)) == 0)
2776 return Qnil;
2777 }
2778
2779 report_file_error ("Adding new name", list2 (file, newname));
2780 }
2781
2782 DEFUN ("make-symbolic-link", Fmake_symbolic_link, Smake_symbolic_link, 2, 3,
2783 "FMake symbolic link to file: \nGMake symbolic link to file %s: \np",
2784 doc: /* Make a symbolic link to TARGET, named LINKNAME.
2785 If LINKNAME is a directory name, make a like-named symbolic link under
2786 LINKNAME.
2787
2788 Signal a `file-already-exists' error if a file LINKNAME already exists
2789 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
2790 An integer third arg means request confirmation if LINKNAME already
2791 exists, and expand leading "~" or strip leading "/:" in TARGET.
2792 This happens for interactive use with M-x. */)
2793 (Lisp_Object target, Lisp_Object linkname, Lisp_Object ok_if_already_exists)
2794 {
2795 Lisp_Object handler;
2796 Lisp_Object encoded_target, encoded_linkname;
2797
2798 CHECK_STRING (target);
2799 if (FIXNUMP (ok_if_already_exists))
2800 {
2801 if (SREF (target, 0) == '~')
2802 target = Fexpand_file_name (target, Qnil);
2803 else if (SREF (target, 0) == '/' && SREF (target, 1) == ':')
2804 target = Fsubstring_no_properties (target, make_fixnum (2), Qnil);
2805 }
2806 linkname = expand_cp_target (target, linkname);
2807
2808 /* If the new link name has special constructs in it,
2809 call the corresponding file name handler. */
2810 handler = Ffind_file_name_handler (linkname, Qmake_symbolic_link);
2811 if (!NILP (handler))
2812 return call4 (handler, Qmake_symbolic_link, target,
2813 linkname, ok_if_already_exists);
2814
2815 encoded_target = ENCODE_FILE (target);
2816 encoded_linkname = ENCODE_FILE (linkname);
2817
2818 if (symlink (SSDATA (encoded_target), SSDATA (encoded_linkname)) == 0)
2819 return Qnil;
2820
2821 if (errno == ENOSYS)
2822 xsignal1 (Qfile_error,
2823 build_string ("Symbolic links are not supported"));
2824
2825 if (errno == EEXIST)
2826 {
2827 if (NILP (ok_if_already_exists)
2828 || FIXNUMP (ok_if_already_exists))
2829 barf_or_query_if_file_exists (linkname, true, "make it a link",
2830 FIXNUMP (ok_if_already_exists), false);
2831 unlink (SSDATA (encoded_linkname));
2832 if (symlink (SSDATA (encoded_target), SSDATA (encoded_linkname)) == 0)
2833 return Qnil;
2834 }
2835
2836 report_file_error ("Making symbolic link", list2 (target, linkname));
2837 }
2838
2839
2840 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p, Sfile_name_absolute_p,
2841 1, 1, 0,
2842 doc: /* Return t if FILENAME is an absolute file name.
2843 On Unix, absolute file names start with `/'. In Emacs, an absolute
2844 file name can also start with an initial `~' or `~USER' component,
2845 where USER is a valid login name. */)
2846 (Lisp_Object filename)
2847 {
2848 CHECK_STRING (filename);
2849 return file_name_absolute_p (SSDATA (filename)) ? Qt : Qnil;
2850 }
2851
2852 bool
file_name_absolute_p(char const * filename)2853 file_name_absolute_p (char const *filename)
2854 {
2855 return (IS_ABSOLUTE_FILE_NAME (filename)
2856 || (filename[0] == '~'
2857 && (!filename[1] || IS_DIRECTORY_SEP (filename[1])
2858 || user_homedir (&filename[1]))));
2859 }
2860
2861 /* Return t if FILE exists and is accessible via OPERATION and AMODE,
2862 nil (setting errno) if not. */
2863
2864 static Lisp_Object
check_file_access(Lisp_Object file,Lisp_Object operation,int amode)2865 check_file_access (Lisp_Object file, Lisp_Object operation, int amode)
2866 {
2867 file = Fexpand_file_name (file, Qnil);
2868 Lisp_Object handler = Ffind_file_name_handler (file, operation);
2869 if (!NILP (handler))
2870 {
2871 Lisp_Object ok = call2 (handler, operation, file);
2872 /* This errno value is bogus. Any caller that depends on errno
2873 should be rethought anyway, to avoid a race between testing a
2874 handled file's accessibility and using the file. */
2875 errno = 0;
2876 return ok;
2877 }
2878
2879 char *encoded_file = SSDATA (ENCODE_FILE (file));
2880 return file_access_p (encoded_file, amode) ? Qt : Qnil;
2881 }
2882
2883 DEFUN ("file-exists-p", Ffile_exists_p, Sfile_exists_p, 1, 1, 0,
2884 doc: /* Return t if file FILENAME exists (whether or not you can read it).
2885 Return nil if FILENAME does not exist, or if there was trouble
2886 determining whether the file exists.
2887 See also `file-readable-p' and `file-attributes'.
2888 This returns nil for a symlink to a nonexistent file.
2889 Use `file-symlink-p' to test for such links. */)
2890 (Lisp_Object filename)
2891 {
2892 return check_file_access (filename, Qfile_exists_p, F_OK);
2893 }
2894
2895 DEFUN ("file-executable-p", Ffile_executable_p, Sfile_executable_p, 1, 1, 0,
2896 doc: /* Return t if FILENAME can be executed by you.
2897 For a directory, this means you can access files in that directory.
2898 \(It is generally better to use `file-accessible-directory-p' for that
2899 purpose, though.) */)
2900 (Lisp_Object filename)
2901 {
2902 return check_file_access (filename, Qfile_executable_p, X_OK);
2903 }
2904
2905 DEFUN ("file-readable-p", Ffile_readable_p, Sfile_readable_p, 1, 1, 0,
2906 doc: /* Return t if file FILENAME exists and you can read it.
2907 See also `file-exists-p' and `file-attributes'. */)
2908 (Lisp_Object filename)
2909 {
2910 return check_file_access (filename, Qfile_readable_p, R_OK);
2911 }
2912
2913 DEFUN ("file-writable-p", Ffile_writable_p, Sfile_writable_p, 1, 1, 0,
2914 doc: /* Return t if file FILENAME can be written or created by you. */)
2915 (Lisp_Object filename)
2916 {
2917 Lisp_Object absname, dir, encoded;
2918 Lisp_Object handler;
2919
2920 absname = Fexpand_file_name (filename, Qnil);
2921
2922 /* If the file name has special constructs in it,
2923 call the corresponding file name handler. */
2924 handler = Ffind_file_name_handler (absname, Qfile_writable_p);
2925 if (!NILP (handler))
2926 return call2 (handler, Qfile_writable_p, absname);
2927
2928 encoded = ENCODE_FILE (absname);
2929 if (file_access_p (SSDATA (encoded), W_OK))
2930 return Qt;
2931 if (errno != ENOENT)
2932 return Qnil;
2933
2934 dir = file_name_directory (absname);
2935 eassert (!NILP (dir));
2936 #ifdef MSDOS
2937 dir = Fdirectory_file_name (dir);
2938 #endif /* MSDOS */
2939
2940 encoded = ENCODE_FILE (dir);
2941 #ifdef WINDOWSNT
2942 /* The read-only attribute of the parent directory doesn't affect
2943 whether a file or directory can be created within it. Some day we
2944 should check ACLs though, which do affect this. */
2945 return file_directory_p (encoded) ? Qt : Qnil;
2946 #else
2947 return file_access_p (SSDATA (encoded), W_OK | X_OK) ? Qt : Qnil;
2948 #endif
2949 }
2950
2951 DEFUN ("access-file", Faccess_file, Saccess_file, 2, 2, 0,
2952 doc: /* Access file FILENAME, and get an error if that does not work.
2953 The second argument STRING is prepended to the error message.
2954 If there is no error, returns nil. */)
2955 (Lisp_Object filename, Lisp_Object string)
2956 {
2957 Lisp_Object handler, encoded_filename, absname;
2958
2959 CHECK_STRING (filename);
2960 absname = Fexpand_file_name (filename, Qnil);
2961
2962 CHECK_STRING (string);
2963
2964 /* If the file name has special constructs in it,
2965 call the corresponding file name handler. */
2966 handler = Ffind_file_name_handler (absname, Qaccess_file);
2967 if (!NILP (handler))
2968 return call3 (handler, Qaccess_file, absname, string);
2969
2970 encoded_filename = ENCODE_FILE (absname);
2971
2972 if (faccessat (AT_FDCWD, SSDATA (encoded_filename), R_OK, AT_EACCESS) != 0)
2973 report_file_error (SSDATA (string), filename);
2974
2975 return Qnil;
2976 }
2977
2978 /* Relative to directory FD, return the symbolic link value of FILENAME.
2979 On failure, return nil (setting errno). */
2980 static Lisp_Object
emacs_readlinkat(int fd,char const * filename)2981 emacs_readlinkat (int fd, char const *filename)
2982 {
2983 static struct allocator const emacs_norealloc_allocator =
2984 { xmalloc, NULL, xfree, memory_full };
2985 Lisp_Object val;
2986 char readlink_buf[1024];
2987 char *buf = careadlinkat (fd, filename, readlink_buf, sizeof readlink_buf,
2988 &emacs_norealloc_allocator, readlinkat);
2989 if (!buf)
2990 return Qnil;
2991
2992 val = build_unibyte_string (buf);
2993 if (buf != readlink_buf)
2994 xfree (buf);
2995 val = DECODE_FILE (val);
2996 return val;
2997 }
2998
2999 /* Relative to directory FD, return the symbolic link value of FILE.
3000 If FILE is not a symbolic link, return nil (setting errno).
3001 Signal an error if the result cannot be determined. */
3002 Lisp_Object
check_emacs_readlinkat(int fd,Lisp_Object file,char const * encoded_file)3003 check_emacs_readlinkat (int fd, Lisp_Object file, char const *encoded_file)
3004 {
3005 Lisp_Object val = emacs_readlinkat (fd, encoded_file);
3006 if (NILP (val))
3007 {
3008 if (errno == EINVAL)
3009 return val;
3010 #ifdef CYGWIN
3011 /* Work around Cygwin bugs. */
3012 if (errno == EIO || errno == EACCES)
3013 return val;
3014 #endif
3015 return file_metadata_errno ("Reading symbolic link", file, errno);
3016 }
3017 return val;
3018 }
3019
3020 DEFUN ("file-symlink-p", Ffile_symlink_p, Sfile_symlink_p, 1, 1, 0,
3021 doc: /* Return non-nil if file FILENAME is the name of a symbolic link.
3022 The value is the link target, as a string.
3023 Return nil if FILENAME does not exist or is not a symbolic link,
3024 of there was trouble determining whether the file is a symbolic link.
3025
3026 This function does not check whether the link target exists. */)
3027 (Lisp_Object filename)
3028 {
3029 Lisp_Object handler;
3030
3031 CHECK_STRING (filename);
3032 filename = Fexpand_file_name (filename, Qnil);
3033
3034 /* If the file name has special constructs in it,
3035 call the corresponding file name handler. */
3036 handler = Ffind_file_name_handler (filename, Qfile_symlink_p);
3037 if (!NILP (handler))
3038 return call2 (handler, Qfile_symlink_p, filename);
3039
3040 return emacs_readlinkat (AT_FDCWD, SSDATA (ENCODE_FILE (filename)));
3041 }
3042
3043 DEFUN ("file-directory-p", Ffile_directory_p, Sfile_directory_p, 1, 1, 0,
3044 doc: /* Return t if FILENAME names an existing directory.
3045 Return nil if FILENAME does not name a directory, or if there
3046 was trouble determining whether FILENAME is a directory.
3047
3048 As a special case, this function will also return t if FILENAME is the
3049 empty string (\"\"). This quirk is due to Emacs interpreting the
3050 empty string (in some cases) as the current directory.
3051
3052 Symbolic links to directories count as directories.
3053 See `file-symlink-p' to distinguish symlinks. */)
3054 (Lisp_Object filename)
3055 {
3056 Lisp_Object absname = expand_and_dir_to_file (filename);
3057
3058 /* If the file name has special constructs in it,
3059 call the corresponding file name handler. */
3060 Lisp_Object handler = Ffind_file_name_handler (absname, Qfile_directory_p);
3061 if (!NILP (handler))
3062 return call2 (handler, Qfile_directory_p, absname);
3063
3064 return file_directory_p (ENCODE_FILE (absname)) ? Qt : Qnil;
3065 }
3066
3067 /* Return true if FILE is a directory or a symlink to a directory.
3068 Otherwise return false and set errno. */
3069 bool
file_directory_p(Lisp_Object file)3070 file_directory_p (Lisp_Object file)
3071 {
3072 #ifdef DOS_NT
3073 /* This is cheaper than 'stat'. */
3074 bool retval = faccessat (AT_FDCWD, SSDATA (file), D_OK, AT_EACCESS) == 0;
3075 if (!retval && errno == EACCES)
3076 errno = ENOTDIR; /* like the non-DOS_NT branch below does */
3077 return retval;
3078 #else
3079 # ifdef O_PATH
3080 /* Use O_PATH if available, as it avoids races and EOVERFLOW issues. */
3081 int fd = emacs_openat (AT_FDCWD, SSDATA (file),
3082 O_PATH | O_CLOEXEC | O_DIRECTORY, 0);
3083 if (0 <= fd)
3084 {
3085 emacs_close (fd);
3086 return true;
3087 }
3088 if (errno != EINVAL)
3089 return false;
3090 /* O_PATH is defined but evidently this Linux kernel predates 2.6.39.
3091 Fall back on generic POSIX code. */
3092 # endif
3093 /* Use file_accessible_directory_p, as it avoids fstatat EOVERFLOW
3094 problems and could be cheaper. However, if it fails because FILE
3095 is inaccessible, fall back on fstatat; if the latter fails with
3096 EOVERFLOW then FILE must have been a directory unless a race
3097 condition occurred (a problem hard to work around portably). */
3098 if (file_accessible_directory_p (file))
3099 return true;
3100 if (errno != EACCES)
3101 return false;
3102 struct stat st;
3103 if (emacs_fstatat (AT_FDCWD, SSDATA (file), &st, 0) != 0)
3104 return errno == EOVERFLOW;
3105 if (S_ISDIR (st.st_mode))
3106 return true;
3107 errno = ENOTDIR;
3108 return false;
3109 #endif
3110 }
3111
3112 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p,
3113 Sfile_accessible_directory_p, 1, 1, 0,
3114 doc: /* Return t if FILENAME names a directory you can open.
3115 This means that FILENAME must specify the name of a directory, and the
3116 directory must allow you to open files in it. If this isn't the case,
3117 return nil.
3118
3119 FILENAME can either be a directory name (eg. \"/tmp/foo/\") or the
3120 file name of a file which is a directory (eg. \"/tmp/foo\", without
3121 the final slash).
3122
3123 In order to use a directory as a buffer's current directory, this
3124 predicate must return true. */)
3125 (Lisp_Object filename)
3126 {
3127 Lisp_Object absname;
3128 Lisp_Object handler;
3129
3130 CHECK_STRING (filename);
3131 absname = Fexpand_file_name (filename, Qnil);
3132
3133 /* If the file name has special constructs in it,
3134 call the corresponding file name handler. */
3135 handler = Ffind_file_name_handler (absname, Qfile_accessible_directory_p);
3136 if (!NILP (handler))
3137 {
3138 Lisp_Object r = call2 (handler, Qfile_accessible_directory_p, absname);
3139
3140 /* Set errno in case the handler failed. EACCES might be a lie
3141 (e.g., the directory might not exist, or be a regular file),
3142 but at least it does TRT in the "usual" case of an existing
3143 directory that is not accessible by the current user, and
3144 avoids reporting "Success" for a failed operation. Perhaps
3145 someday we can fix this in a better way, by improving
3146 file-accessible-directory-p's API; see Bug#25419. */
3147 if (!EQ (r, Qt))
3148 errno = EACCES;
3149
3150 return r;
3151 }
3152
3153 Lisp_Object encoded_absname = ENCODE_FILE (absname);
3154 return file_accessible_directory_p (encoded_absname) ? Qt : Qnil;
3155 }
3156
3157 /* If FILE is a searchable directory or a symlink to a
3158 searchable directory, return true. Otherwise return
3159 false and set errno to an error number. */
3160 bool
file_accessible_directory_p(Lisp_Object file)3161 file_accessible_directory_p (Lisp_Object file)
3162 {
3163 #ifdef DOS_NT
3164 # ifdef WINDOWSNT
3165 /* We need a special-purpose test because (a) NTFS security data is
3166 not reflected in Posix-style mode bits, and (b) the trick with
3167 accessing "DIR/.", used below on Posix hosts, doesn't work on
3168 Windows, because "DIR/." is normalized to just "DIR" before
3169 hitting the disk. */
3170 return (SBYTES (file) == 0
3171 || w32_accessible_directory_p (SSDATA (file), SBYTES (file)));
3172 # else /* MSDOS */
3173 return file_directory_p (file);
3174 # endif /* MSDOS */
3175 #else /* !DOS_NT */
3176 /* On POSIXish platforms, use just one system call; this avoids a
3177 race and is typically faster. */
3178 const char *data = SSDATA (file);
3179 ptrdiff_t len = SBYTES (file);
3180 char const *dir;
3181 bool ok;
3182 USE_SAFE_ALLOCA;
3183
3184 /* Normally a file "FOO" is an accessible directory if "FOO/." exists.
3185 There are three exceptions: "", "/", and "//". Leave "" alone,
3186 as it's invalid. Append only "." to the other two exceptions as
3187 "/" and "//" are distinct on some platforms, whereas "/", "///",
3188 "////", etc. are all equivalent. */
3189 if (! len)
3190 dir = data;
3191 else
3192 {
3193 /* Just check for trailing '/' when deciding whether append '/'
3194 before appending '.'. That's simpler than testing the two
3195 special cases "/" and "//", and it's a safe optimization
3196 here. After appending '.', append another '/' to work around
3197 a macOS bug (Bug#30350). */
3198 static char const appended[] = "/./";
3199 char *buf = SAFE_ALLOCA (len + sizeof appended);
3200 memcpy (buf, data, len);
3201 strcpy (buf + len, &appended[data[len - 1] == '/']);
3202 dir = buf;
3203 }
3204
3205 ok = file_access_p (dir, F_OK);
3206 SAFE_FREE ();
3207 return ok;
3208 #endif /* !DOS_NT */
3209 }
3210
3211 DEFUN ("file-regular-p", Ffile_regular_p, Sfile_regular_p, 1, 1, 0,
3212 doc: /* Return t if FILENAME names a regular file.
3213 This is the sort of file that holds an ordinary stream of data bytes.
3214 Return nil if FILENAME does not exist or is not a regular file,
3215 or there was trouble determining whether FILENAME is a regular file.
3216 Symbolic links to regular files count as regular files.
3217 See `file-symlink-p' to distinguish symlinks. */)
3218 (Lisp_Object filename)
3219 {
3220 struct stat st;
3221 Lisp_Object absname = expand_and_dir_to_file (filename);
3222
3223 /* If the file name has special constructs in it,
3224 call the corresponding file name handler. */
3225 Lisp_Object handler = Ffind_file_name_handler (absname, Qfile_regular_p);
3226 if (!NILP (handler))
3227 return call2 (handler, Qfile_regular_p, absname);
3228
3229 #ifdef WINDOWSNT
3230 /* Tell stat to use expensive method to get accurate info. */
3231 Lisp_Object true_attributes = Vw32_get_true_file_attributes;
3232 Vw32_get_true_file_attributes = Qt;
3233 #endif
3234
3235 int stat_result = emacs_fstatat (AT_FDCWD, SSDATA (absname), &st, 0);
3236
3237 #ifdef WINDOWSNT
3238 Vw32_get_true_file_attributes = true_attributes;
3239 #endif
3240
3241 return stat_result == 0 && S_ISREG (st.st_mode) ? Qt : Qnil;
3242 }
3243
3244 DEFUN ("file-selinux-context", Ffile_selinux_context,
3245 Sfile_selinux_context, 1, 1, 0,
3246 doc: /* Return SELinux context of file named FILENAME.
3247 The return value is a list (USER ROLE TYPE RANGE), where the list
3248 elements are strings naming the user, role, type, and range of the
3249 file's SELinux security context.
3250
3251 Return (nil nil nil nil) if the file is nonexistent,
3252 or if SELinux is disabled, or if Emacs lacks SELinux support. */)
3253 (Lisp_Object filename)
3254 {
3255 Lisp_Object user = Qnil, role = Qnil, type = Qnil, range = Qnil;
3256 Lisp_Object absname = expand_and_dir_to_file (filename);
3257
3258 /* If the file name has special constructs in it,
3259 call the corresponding file name handler. */
3260 Lisp_Object handler = Ffind_file_name_handler (absname,
3261 Qfile_selinux_context);
3262 if (!NILP (handler))
3263 return call2 (handler, Qfile_selinux_context, absname);
3264
3265 #if HAVE_LIBSELINUX
3266 if (is_selinux_enabled ())
3267 {
3268 char *con;
3269 int conlength = lgetfilecon (SSDATA (ENCODE_FILE (absname)), &con);
3270 if (conlength > 0)
3271 {
3272 context_t context = context_new (con);
3273 if (context_user_get (context))
3274 user = build_string (context_user_get (context));
3275 if (context_role_get (context))
3276 role = build_string (context_role_get (context));
3277 if (context_type_get (context))
3278 type = build_string (context_type_get (context));
3279 if (context_range_get (context))
3280 range = build_string (context_range_get (context));
3281 context_free (context);
3282 freecon (con);
3283 }
3284 else if (! (errno == ENOENT || errno == ENOTDIR || errno == ENODATA
3285 || errno == ENOTSUP))
3286 report_file_error ("getting SELinux context", absname);
3287 }
3288 #endif
3289
3290 return list4 (user, role, type, range);
3291 }
3292
3293 DEFUN ("set-file-selinux-context", Fset_file_selinux_context,
3294 Sset_file_selinux_context, 2, 2, 0,
3295 doc: /* Set SELinux context of file named FILENAME to CONTEXT.
3296 CONTEXT should be a list (USER ROLE TYPE RANGE), where the list
3297 elements are strings naming the components of a SELinux context.
3298
3299 Value is t if setting of SELinux context was successful, nil otherwise.
3300
3301 This function does nothing and returns nil if SELinux is disabled,
3302 or if Emacs was not compiled with SELinux support. */)
3303 (Lisp_Object filename, Lisp_Object context)
3304 {
3305 Lisp_Object absname;
3306 Lisp_Object handler;
3307 #if HAVE_LIBSELINUX
3308 Lisp_Object encoded_absname;
3309 Lisp_Object user = CAR_SAFE (context);
3310 Lisp_Object role = CAR_SAFE (CDR_SAFE (context));
3311 Lisp_Object type = CAR_SAFE (CDR_SAFE (CDR_SAFE (context)));
3312 Lisp_Object range = CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (context))));
3313 char *con;
3314 bool fail;
3315 int conlength;
3316 context_t parsed_con;
3317 #endif
3318
3319 absname = Fexpand_file_name (filename, BVAR (current_buffer, directory));
3320
3321 /* If the file name has special constructs in it,
3322 call the corresponding file name handler. */
3323 handler = Ffind_file_name_handler (absname, Qset_file_selinux_context);
3324 if (!NILP (handler))
3325 return call3 (handler, Qset_file_selinux_context, absname, context);
3326
3327 #if HAVE_LIBSELINUX
3328 if (is_selinux_enabled ())
3329 {
3330 /* Get current file context. */
3331 encoded_absname = ENCODE_FILE (absname);
3332 conlength = lgetfilecon (SSDATA (encoded_absname), &con);
3333 if (conlength > 0)
3334 {
3335 parsed_con = context_new (con);
3336 /* Change the parts defined in the parameter.*/
3337 if (STRINGP (user))
3338 {
3339 if (context_user_set (parsed_con, SSDATA (user)))
3340 error ("Doing context_user_set");
3341 }
3342 if (STRINGP (role))
3343 {
3344 if (context_role_set (parsed_con, SSDATA (role)))
3345 error ("Doing context_role_set");
3346 }
3347 if (STRINGP (type))
3348 {
3349 if (context_type_set (parsed_con, SSDATA (type)))
3350 error ("Doing context_type_set");
3351 }
3352 if (STRINGP (range))
3353 {
3354 if (context_range_set (parsed_con, SSDATA (range)))
3355 error ("Doing context_range_set");
3356 }
3357
3358 /* Set the modified context back to the file. */
3359 fail = (lsetfilecon (SSDATA (encoded_absname),
3360 context_str (parsed_con))
3361 != 0);
3362 /* See https://debbugs.gnu.org/11245 for ENOTSUP. */
3363 if (fail && errno != ENOTSUP)
3364 report_file_error ("Doing lsetfilecon", absname);
3365
3366 context_free (parsed_con);
3367 freecon (con);
3368 return fail ? Qnil : Qt;
3369 }
3370 else
3371 report_file_error ("Doing lgetfilecon", absname);
3372 }
3373 #endif
3374
3375 return Qnil;
3376 }
3377
3378 DEFUN ("file-acl", Ffile_acl, Sfile_acl, 1, 1, 0,
3379 doc: /* Return ACL entries of file named FILENAME.
3380 The entries are returned in a format suitable for use in `set-file-acl'
3381 but is otherwise undocumented and subject to change.
3382 Return nil if file does not exist. */)
3383 (Lisp_Object filename)
3384 {
3385 Lisp_Object acl_string = Qnil;
3386
3387 #if USE_ACL
3388 Lisp_Object absname = expand_and_dir_to_file (filename);
3389
3390 /* If the file name has special constructs in it,
3391 call the corresponding file name handler. */
3392 Lisp_Object handler = Ffind_file_name_handler (absname, Qfile_acl);
3393 if (!NILP (handler))
3394 return call2 (handler, Qfile_acl, absname);
3395
3396 # ifdef HAVE_ACL_SET_FILE
3397 # ifndef HAVE_ACL_TYPE_EXTENDED
3398 acl_type_t ACL_TYPE_EXTENDED = ACL_TYPE_ACCESS;
3399 # endif
3400 acl_t acl = acl_get_file (SSDATA (ENCODE_FILE (absname)), ACL_TYPE_EXTENDED);
3401 if (acl == NULL)
3402 {
3403 if (errno == ENOENT || errno == ENOTDIR || !acl_errno_valid (errno))
3404 return Qnil;
3405 report_file_error ("Getting ACLs", absname);
3406 }
3407 char *str = acl_to_text (acl, NULL);
3408 if (str == NULL)
3409 {
3410 int err = errno;
3411 acl_free (acl);
3412 report_file_errno ("Getting ACLs", absname, err);
3413 }
3414
3415 acl_string = build_string (str);
3416 acl_free (str);
3417 acl_free (acl);
3418 # endif
3419 #endif
3420
3421 return acl_string;
3422 }
3423
3424 DEFUN ("set-file-acl", Fset_file_acl, Sset_file_acl,
3425 2, 2, 0,
3426 doc: /* Set ACL of file named FILENAME to ACL-STRING.
3427 ACL-STRING should contain the textual representation of the ACL
3428 entries in a format suitable for the platform.
3429
3430 Value is t if setting of ACL was successful, nil otherwise.
3431
3432 Setting ACL for local files requires Emacs to be built with ACL
3433 support. */)
3434 (Lisp_Object filename, Lisp_Object acl_string)
3435 {
3436 #if USE_ACL
3437 Lisp_Object absname;
3438 Lisp_Object handler;
3439 # ifdef HAVE_ACL_SET_FILE
3440 Lisp_Object encoded_absname;
3441 acl_t acl;
3442 bool fail;
3443 # endif
3444
3445 absname = Fexpand_file_name (filename, BVAR (current_buffer, directory));
3446
3447 /* If the file name has special constructs in it,
3448 call the corresponding file name handler. */
3449 handler = Ffind_file_name_handler (absname, Qset_file_acl);
3450 if (!NILP (handler))
3451 return call3 (handler, Qset_file_acl, absname, acl_string);
3452
3453 # ifdef HAVE_ACL_SET_FILE
3454 if (STRINGP (acl_string))
3455 {
3456 acl = acl_from_text (SSDATA (acl_string));
3457 if (acl == NULL)
3458 {
3459 if (acl_errno_valid (errno))
3460 report_file_error ("Converting ACL", absname);
3461 return Qnil;
3462 }
3463
3464 encoded_absname = ENCODE_FILE (absname);
3465
3466 fail = (acl_set_file (SSDATA (encoded_absname), ACL_TYPE_ACCESS,
3467 acl)
3468 != 0);
3469 if (fail && acl_errno_valid (errno))
3470 report_file_error ("Setting ACL", absname);
3471
3472 acl_free (acl);
3473 return fail ? Qnil : Qt;
3474 }
3475 # endif
3476 #endif
3477
3478 return Qnil;
3479 }
3480
3481 static int
symlink_nofollow_flag(Lisp_Object flag)3482 symlink_nofollow_flag (Lisp_Object flag)
3483 {
3484 /* For now, treat all non-nil FLAGs like 'nofollow'. */
3485 return !NILP (flag) ? AT_SYMLINK_NOFOLLOW : 0;
3486 }
3487
3488 DEFUN ("file-modes", Ffile_modes, Sfile_modes, 1, 2, 0,
3489 doc: /* Return mode bits of file named FILENAME, as an integer.
3490 Return nil if FILENAME does not exist. If optional FLAG is `nofollow',
3491 do not follow FILENAME if it is a symbolic link. */)
3492 (Lisp_Object filename, Lisp_Object flag)
3493 {
3494 struct stat st;
3495 int nofollow = symlink_nofollow_flag (flag);
3496 Lisp_Object absname = expand_and_dir_to_file (filename);
3497
3498 /* If the file name has special constructs in it,
3499 call the corresponding file name handler. */
3500 Lisp_Object handler = Ffind_file_name_handler (absname, Qfile_modes);
3501 if (!NILP (handler))
3502 return call3 (handler, Qfile_modes, absname, flag);
3503
3504 char *fname = SSDATA (ENCODE_FILE (absname));
3505 if (emacs_fstatat (AT_FDCWD, fname, &st, nofollow) != 0)
3506 return file_attribute_errno (absname, errno);
3507 return make_fixnum (st.st_mode & 07777);
3508 }
3509
3510 DEFUN ("set-file-modes", Fset_file_modes, Sset_file_modes, 2, 3,
3511 "(let ((file (read-file-name \"File: \"))) \
3512 (list file (read-file-modes nil file)))",
3513 doc: /* Set mode bits of file named FILENAME to MODE (an integer).
3514 Only the 12 low bits of MODE are used. If optional FLAG is `nofollow',
3515 do not follow FILENAME if it is a symbolic link.
3516
3517 Interactively, mode bits are read by `read-file-modes', which accepts
3518 symbolic notation, like the `chmod' command from GNU Coreutils. */)
3519 (Lisp_Object filename, Lisp_Object mode, Lisp_Object flag)
3520 {
3521 CHECK_FIXNUM (mode);
3522 int nofollow = symlink_nofollow_flag (flag);
3523 Lisp_Object absname = Fexpand_file_name (filename,
3524 BVAR (current_buffer, directory));
3525
3526 /* If the file name has special constructs in it,
3527 call the corresponding file name handler. */
3528 Lisp_Object handler = Ffind_file_name_handler (absname, Qset_file_modes);
3529 if (!NILP (handler))
3530 return call4 (handler, Qset_file_modes, absname, mode, flag);
3531
3532 char *fname = SSDATA (ENCODE_FILE (absname));
3533 mode_t imode = XFIXNUM (mode) & 07777;
3534 if (fchmodat (AT_FDCWD, fname, imode, nofollow) != 0)
3535 report_file_error ("Doing chmod", absname);
3536
3537 return Qnil;
3538 }
3539
3540 DEFUN ("set-default-file-modes", Fset_default_file_modes, Sset_default_file_modes, 1, 1, 0,
3541 doc: /* Set the file permission bits for newly created files.
3542 The argument MODE should be an integer; only the low 9 bits are used.
3543 On Posix hosts, this setting is inherited by subprocesses.
3544
3545 This function works by setting the Emacs's file mode creation mask.
3546 Each bit that is set in the mask means that the corresponding bit
3547 in the permissions of newly created files will be disabled.
3548
3549 Note that when `write-region' creates a file, it resets the
3550 execute bit, even if the mask set by this function allows that bit
3551 by having the corresponding bit in the mask reset. */)
3552 (Lisp_Object mode)
3553 {
3554 mode_t oldrealmask, oldumask, newumask;
3555 CHECK_FIXNUM (mode);
3556 oldrealmask = realmask;
3557 newumask = ~ XFIXNUM (mode) & 0777;
3558
3559 block_input ();
3560 realmask = newumask;
3561 oldumask = umask (newumask);
3562 unblock_input ();
3563
3564 eassert (oldumask == oldrealmask);
3565 return Qnil;
3566 }
3567
3568 DEFUN ("default-file-modes", Fdefault_file_modes, Sdefault_file_modes, 0, 0, 0,
3569 doc: /* Return the default file protection for created files.
3570 The value is an integer. */)
3571 (void)
3572 {
3573 Lisp_Object value;
3574 XSETINT (value, (~ realmask) & 0777);
3575 return value;
3576 }
3577
3578
3579 DEFUN ("set-file-times", Fset_file_times, Sset_file_times, 1, 3, 0,
3580 doc: /* Set times of file FILENAME to TIMESTAMP.
3581 If optional FLAG is `nofollow', do not follow FILENAME if it is a
3582 symbolic link. Set both access and modification times. Return t on
3583 success, else nil. Use the current time if TIMESTAMP is nil.
3584 TIMESTAMP is in the format of `current-time'. */)
3585 (Lisp_Object filename, Lisp_Object timestamp, Lisp_Object flag)
3586 {
3587 int nofollow = symlink_nofollow_flag (flag);
3588
3589 struct timespec ts[2];
3590 if (!NILP (timestamp))
3591 ts[0] = ts[1] = lisp_time_argument (timestamp);
3592 else
3593 ts[0].tv_nsec = ts[1].tv_nsec = UTIME_NOW;
3594
3595 /* If the file name has special constructs in it,
3596 call the corresponding file name handler. */
3597 Lisp_Object
3598 absname = Fexpand_file_name (filename, BVAR (current_buffer, directory)),
3599 handler = Ffind_file_name_handler (absname, Qset_file_times);
3600 if (!NILP (handler))
3601 return call4 (handler, Qset_file_times, absname, timestamp, flag);
3602
3603 Lisp_Object encoded_absname = ENCODE_FILE (absname);
3604
3605 if (utimensat (AT_FDCWD, SSDATA (encoded_absname), ts, nofollow) != 0)
3606 {
3607 #ifdef MSDOS
3608 /* Setting times on a directory always fails. */
3609 if (file_directory_p (encoded_absname))
3610 return Qnil;
3611 #endif
3612 report_file_error ("Setting file times", absname);
3613 }
3614
3615 return Qt;
3616 }
3617
3618 #ifdef HAVE_SYNC
3619 DEFUN ("unix-sync", Funix_sync, Sunix_sync, 0, 0, "",
3620 doc: /* Tell Unix to finish all pending disk updates. */)
3621 (void)
3622 {
3623 sync ();
3624 return Qnil;
3625 }
3626
3627 #endif /* HAVE_SYNC */
3628
3629 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p, Sfile_newer_than_file_p, 2, 2, 0,
3630 doc: /* Return t if file FILE1 is newer than file FILE2.
3631 If FILE1 does not exist, the answer is nil;
3632 otherwise, if FILE2 does not exist, the answer is t. */)
3633 (Lisp_Object file1, Lisp_Object file2)
3634 {
3635 struct stat st1, st2;
3636
3637 CHECK_STRING (file1);
3638 CHECK_STRING (file2);
3639
3640 Lisp_Object absname1 = expand_and_dir_to_file (file1);
3641 Lisp_Object absname2 = expand_and_dir_to_file (file2);
3642
3643 /* If the file name has special constructs in it,
3644 call the corresponding file name handler. */
3645 Lisp_Object handler = Ffind_file_name_handler (absname1,
3646 Qfile_newer_than_file_p);
3647 if (NILP (handler))
3648 handler = Ffind_file_name_handler (absname2, Qfile_newer_than_file_p);
3649 if (!NILP (handler))
3650 return call3 (handler, Qfile_newer_than_file_p, absname1, absname2);
3651
3652 int err1;
3653 if (emacs_fstatat (AT_FDCWD, SSDATA (ENCODE_FILE (absname1)), &st1, 0) == 0)
3654 err1 = 0;
3655 else
3656 {
3657 err1 = errno;
3658 if (err1 != EOVERFLOW)
3659 return file_attribute_errno (absname1, err1);
3660 }
3661 if (emacs_fstatat (AT_FDCWD, SSDATA (ENCODE_FILE (absname2)), &st2, 0) != 0)
3662 {
3663 file_attribute_errno (absname2, errno);
3664 return Qt;
3665 }
3666 if (err1)
3667 file_attribute_errno (absname1, err1);
3668
3669 return (timespec_cmp (get_stat_mtime (&st2), get_stat_mtime (&st1)) < 0
3670 ? Qt : Qnil);
3671 }
3672
3673 enum { READ_BUF_SIZE = MAX_ALLOCA };
3674
3675 /* This function is called after Lisp functions to decide a coding
3676 system are called, or when they cause an error. Before they are
3677 called, the current buffer is set unibyte and it contains only a
3678 newly inserted text (thus the buffer was empty before the
3679 insertion).
3680
3681 The functions may set markers, overlays, text properties, or even
3682 alter the buffer contents, change the current buffer.
3683
3684 Here, we reset all those changes by:
3685 o set back the current buffer.
3686 o move all markers and overlays to BEG.
3687 o remove all text properties.
3688 o set back the buffer multibyteness. */
3689
3690 static void
decide_coding_unwind(Lisp_Object unwind_data)3691 decide_coding_unwind (Lisp_Object unwind_data)
3692 {
3693 Lisp_Object multibyte = XCAR (unwind_data);
3694 Lisp_Object tmp = XCDR (unwind_data);
3695 Lisp_Object undo_list = XCAR (tmp);
3696 Lisp_Object buffer = XCDR (tmp);
3697
3698 set_buffer_internal (XBUFFER (buffer));
3699
3700 /* We're about to "delete" the text by moving it back into the gap.
3701 So move markers that set-auto-coding might have created to BEG,
3702 just in case. */
3703 adjust_markers_for_delete (BEG, BEG_BYTE, Z, Z_BYTE);
3704 adjust_overlays_for_delete (BEG, Z - BEG);
3705 set_buffer_intervals (current_buffer, NULL);
3706 TEMP_SET_PT_BOTH (BEG, BEG_BYTE);
3707
3708 /* In case of a non-local exit from set_auto_coding_function, in order not
3709 to end up with potentially invalid byte sequences in a multibyte buffer,
3710 we have the following options:
3711 1- decode the bytes in some arbitrary coding-system.
3712 2- erase the buffer.
3713 3- leave the buffer unibyte (which is actually the same as option (1)
3714 where the coding-system is `raw-text-unix`).
3715 Here we choose 2. */
3716
3717 /* Move the bytes back to (the beginning of) the gap.
3718 In general this may have to move all the bytes, but here
3719 this can't move more bytes than were moved during the execution
3720 of Vset_auto_coding_function, which is normally 0 (because it
3721 normally doesn't modify the buffer). */
3722 move_gap_both (Z, Z_BYTE);
3723 ptrdiff_t inserted = Z_BYTE - BEG_BYTE;
3724 GAP_SIZE += inserted;
3725 ZV = Z = GPT = BEG;
3726 ZV_BYTE = Z_BYTE = GPT_BYTE = BEG_BYTE;
3727
3728 /* Pass the new `inserted` back. */
3729 XSETCAR (unwind_data, make_fixnum (inserted));
3730
3731 /* Now we are safe to change the buffer's multibyteness directly. */
3732 bset_enable_multibyte_characters (current_buffer, multibyte);
3733 bset_undo_list (current_buffer, undo_list);
3734 }
3735
3736 /* Read from a non-regular file. Return the number of bytes read. */
3737
3738 union read_non_regular
3739 {
3740 struct
3741 {
3742 int fd;
3743 ptrdiff_t inserted, trytry;
3744 } s;
3745 GCALIGNED_UNION_MEMBER
3746 };
3747 verify (GCALIGNED (union read_non_regular));
3748
3749 static Lisp_Object
read_non_regular(Lisp_Object state)3750 read_non_regular (Lisp_Object state)
3751 {
3752 union read_non_regular *data = XFIXNUMPTR (state);
3753 int nbytes = emacs_read_quit (data->s.fd,
3754 ((char *) BEG_ADDR + PT_BYTE - BEG_BYTE
3755 + data->s.inserted),
3756 data->s.trytry);
3757 return make_fixnum (nbytes);
3758 }
3759
3760
3761 /* Condition-case handler used when reading from non-regular files
3762 in insert-file-contents. */
3763
3764 static Lisp_Object
read_non_regular_quit(Lisp_Object ignore)3765 read_non_regular_quit (Lisp_Object ignore)
3766 {
3767 return Qnil;
3768 }
3769
3770 /* Return the file offset that VAL represents, checking for type
3771 errors and overflow. */
3772 static off_t
file_offset(Lisp_Object val)3773 file_offset (Lisp_Object val)
3774 {
3775 if (INTEGERP (val))
3776 {
3777 intmax_t v;
3778 if (integer_to_intmax (val, &v) && 0 <= v && v <= TYPE_MAXIMUM (off_t))
3779 return v;
3780 }
3781 else if (FLOATP (val))
3782 {
3783 double v = XFLOAT_DATA (val);
3784 if (0 <= v && v < 1.0 + TYPE_MAXIMUM (off_t))
3785 {
3786 off_t o = v;
3787 if (o == v)
3788 return o;
3789 }
3790 }
3791
3792 wrong_type_argument (intern ("file-offset"), val);
3793 }
3794
3795 /* Return a special time value indicating the error number ERRNUM. */
3796 static struct timespec
time_error_value(int errnum)3797 time_error_value (int errnum)
3798 {
3799 int ns = (errnum == ENOENT || errnum == ENOTDIR
3800 ? NONEXISTENT_MODTIME_NSECS
3801 : UNKNOWN_MODTIME_NSECS);
3802 return make_timespec (0, ns);
3803 }
3804
3805 static Lisp_Object
get_window_points_and_markers(void)3806 get_window_points_and_markers (void)
3807 {
3808 Lisp_Object pt_marker = Fpoint_marker ();
3809 Lisp_Object windows
3810 = call3 (Qget_buffer_window_list, Fcurrent_buffer (), Qnil, Qt);
3811 Lisp_Object window_markers = windows;
3812 /* Window markers (and point) are handled specially: rather than move to
3813 just before or just after the modified text, we try to keep the
3814 markers at the same distance (bug#19161).
3815 In general, this is wrong, but for window-markers, this should be harmless
3816 and is convenient for the end user when most of the file is unmodified,
3817 except for a few minor details near the beginning and near the end. */
3818 for (; CONSP (windows); windows = XCDR (windows))
3819 if (WINDOWP (XCAR (windows)))
3820 {
3821 Lisp_Object window_marker = XWINDOW (XCAR (windows))->pointm;
3822 XSETCAR (windows,
3823 Fcons (window_marker, Fmarker_position (window_marker)));
3824 }
3825 return Fcons (Fcons (pt_marker, Fpoint ()), window_markers);
3826 }
3827
3828 static void
restore_window_points(Lisp_Object window_markers,ptrdiff_t inserted,ptrdiff_t same_at_start,ptrdiff_t same_at_end)3829 restore_window_points (Lisp_Object window_markers, ptrdiff_t inserted,
3830 ptrdiff_t same_at_start, ptrdiff_t same_at_end)
3831 {
3832 for (; CONSP (window_markers); window_markers = XCDR (window_markers))
3833 if (CONSP (XCAR (window_markers)))
3834 {
3835 Lisp_Object car = XCAR (window_markers);
3836 Lisp_Object marker = XCAR (car);
3837 Lisp_Object oldpos = XCDR (car);
3838 if (MARKERP (marker) && FIXNUMP (oldpos)
3839 && XFIXNUM (oldpos) > same_at_start
3840 && XFIXNUM (oldpos) <= same_at_end)
3841 {
3842 ptrdiff_t oldsize = same_at_end - same_at_start;
3843 ptrdiff_t newsize = inserted;
3844 double growth = newsize / (double)oldsize;
3845 ptrdiff_t newpos
3846 = same_at_start + growth * (XFIXNUM (oldpos) - same_at_start);
3847 Fset_marker (marker, make_fixnum (newpos), Qnil);
3848 }
3849 }
3850 }
3851
3852 /* Make sure the gap is at Z_BYTE. This is required to treat buffer
3853 text as a linear C char array. */
3854 static void
maybe_move_gap(struct buffer * b)3855 maybe_move_gap (struct buffer *b)
3856 {
3857 if (BUF_GPT_BYTE (b) != BUF_Z_BYTE (b))
3858 {
3859 struct buffer *cb = current_buffer;
3860
3861 set_buffer_internal (b);
3862 move_gap_both (Z, Z_BYTE);
3863 set_buffer_internal (cb);
3864 }
3865 }
3866
3867 /* FIXME: insert-file-contents should be split with the top-level moved to
3868 Elisp and only the core kept in C. */
3869
3870 DEFUN ("insert-file-contents", Finsert_file_contents, Sinsert_file_contents,
3871 1, 5, 0,
3872 doc: /* Insert contents of file FILENAME after point.
3873 Returns list of absolute file name and number of characters inserted.
3874 If second argument VISIT is non-nil, the buffer's visited filename and
3875 last save file modtime are set, and it is marked unmodified. If
3876 visiting and the file does not exist, visiting is completed before the
3877 error is signaled.
3878
3879 The optional third and fourth arguments BEG and END specify what portion
3880 of the file to insert. These arguments count bytes in the file, not
3881 characters in the buffer. If VISIT is non-nil, BEG and END must be nil.
3882
3883 If optional fifth argument REPLACE is non-nil, replace the current
3884 buffer contents (in the accessible portion) with the file contents.
3885 This is better than simply deleting and inserting the whole thing
3886 because (1) it preserves some marker positions (in unchanged portions
3887 at the start and end of the buffer) and (2) it puts less data in the
3888 undo list. When REPLACE is non-nil, the second return value is the
3889 number of characters that replace previous buffer contents.
3890
3891 This function does code conversion according to the value of
3892 `coding-system-for-read' or `file-coding-system-alist', and sets the
3893 variable `last-coding-system-used' to the coding system actually used.
3894
3895 In addition, this function decodes the inserted text from known formats
3896 by calling `format-decode', which see. */)
3897 (Lisp_Object filename, Lisp_Object visit, Lisp_Object beg, Lisp_Object end, Lisp_Object replace)
3898 {
3899 struct stat st;
3900 struct timespec mtime;
3901 int fd;
3902 ptrdiff_t inserted = 0;
3903 ptrdiff_t how_much;
3904 off_t beg_offset, end_offset;
3905 int unprocessed;
3906 ptrdiff_t count = SPECPDL_INDEX ();
3907 Lisp_Object handler, val, insval, orig_filename, old_undo;
3908 Lisp_Object p;
3909 ptrdiff_t total = 0;
3910 bool not_regular = 0;
3911 int save_errno = 0;
3912 char read_buf[READ_BUF_SIZE];
3913 struct coding_system coding;
3914 bool replace_handled = false;
3915 bool set_coding_system = false;
3916 Lisp_Object coding_system;
3917 bool read_quit = false;
3918 /* If the undo log only contains the insertion, there's no point
3919 keeping it. It's typically when we first fill a file-buffer. */
3920 bool empty_undo_list_p
3921 = (!NILP (visit) && NILP (BVAR (current_buffer, undo_list))
3922 && BEG == Z);
3923 Lisp_Object old_Vdeactivate_mark = Vdeactivate_mark;
3924 bool we_locked_file = false;
3925 ptrdiff_t fd_index;
3926 Lisp_Object window_markers = Qnil;
3927 /* same_at_start and same_at_end count bytes, because file access counts
3928 bytes and BEG and END count bytes. */
3929 ptrdiff_t same_at_start = BEGV_BYTE;
3930 ptrdiff_t same_at_end = ZV_BYTE;
3931 /* SAME_AT_END_CHARPOS counts characters, because
3932 restore_window_points needs the old character count. */
3933 ptrdiff_t same_at_end_charpos = ZV;
3934
3935 if (current_buffer->base_buffer && ! NILP (visit))
3936 error ("Cannot do file visiting in an indirect buffer");
3937
3938 if (!NILP (BVAR (current_buffer, read_only)))
3939 Fbarf_if_buffer_read_only (Qnil);
3940
3941 val = Qnil;
3942 p = Qnil;
3943 orig_filename = Qnil;
3944 old_undo = Qnil;
3945
3946 CHECK_STRING (filename);
3947 filename = Fexpand_file_name (filename, Qnil);
3948
3949 /* The value Qnil means that the coding system is not yet
3950 decided. */
3951 coding_system = Qnil;
3952
3953 /* If the file name has special constructs in it,
3954 call the corresponding file name handler. */
3955 handler = Ffind_file_name_handler (filename, Qinsert_file_contents);
3956 if (!NILP (handler))
3957 {
3958 val = call6 (handler, Qinsert_file_contents, filename,
3959 visit, beg, end, replace);
3960 if (CONSP (val) && CONSP (XCDR (val))
3961 && RANGED_FIXNUMP (0, XCAR (XCDR (val)), ZV - PT))
3962 inserted = XFIXNUM (XCAR (XCDR (val)));
3963 goto handled;
3964 }
3965
3966 orig_filename = filename;
3967 filename = ENCODE_FILE (filename);
3968
3969 fd = emacs_open (SSDATA (filename), O_RDONLY, 0);
3970 if (fd < 0)
3971 {
3972 save_errno = errno;
3973 if (NILP (visit))
3974 report_file_error ("Opening input file", orig_filename);
3975 mtime = time_error_value (save_errno);
3976 st.st_size = -1;
3977 if (!NILP (Vcoding_system_for_read))
3978 {
3979 /* Don't let invalid values into buffer-file-coding-system. */
3980 CHECK_CODING_SYSTEM (Vcoding_system_for_read);
3981 Fset (Qbuffer_file_coding_system, Vcoding_system_for_read);
3982 }
3983 eassert (inserted == 0);
3984 goto notfound;
3985 }
3986
3987 fd_index = SPECPDL_INDEX ();
3988 record_unwind_protect_int (close_file_unwind, fd);
3989
3990 /* Replacement should preserve point as it preserves markers. */
3991 if (!NILP (replace))
3992 {
3993 window_markers = get_window_points_and_markers ();
3994 record_unwind_protect (restore_point_unwind,
3995 XCAR (XCAR (window_markers)));
3996 }
3997
3998 if (fstat (fd, &st) != 0)
3999 report_file_error ("Input file status", orig_filename);
4000 mtime = get_stat_mtime (&st);
4001
4002 /* This code will need to be changed in order to work on named
4003 pipes, and it's probably just not worth it. So we should at
4004 least signal an error. */
4005 if (!S_ISREG (st.st_mode))
4006 {
4007 not_regular = 1;
4008
4009 if (! NILP (visit))
4010 {
4011 eassert (inserted == 0);
4012 goto notfound;
4013 }
4014
4015 if (! NILP (replace) || ! NILP (beg) || ! NILP (end))
4016 xsignal2 (Qfile_error,
4017 build_string ("not a regular file"), orig_filename);
4018 }
4019
4020 if (!NILP (visit))
4021 {
4022 if (!NILP (beg) || !NILP (end))
4023 error ("Attempt to visit less than an entire file");
4024 if (BEG < Z && NILP (replace))
4025 error ("Cannot do file visiting in a non-empty buffer");
4026 }
4027
4028 if (!NILP (beg))
4029 beg_offset = file_offset (beg);
4030 else
4031 beg_offset = 0;
4032
4033 if (!NILP (end))
4034 end_offset = file_offset (end);
4035 else
4036 {
4037 if (not_regular)
4038 end_offset = TYPE_MAXIMUM (off_t);
4039 else
4040 {
4041 end_offset = st.st_size;
4042
4043 /* A negative size can happen on a platform that allows file
4044 sizes greater than the maximum off_t value. */
4045 if (end_offset < 0)
4046 buffer_overflow ();
4047
4048 /* The file size returned from fstat may be zero, but data
4049 may be readable nonetheless, for example when this is a
4050 file in the /proc filesystem. */
4051 if (end_offset == 0)
4052 end_offset = READ_BUF_SIZE;
4053 }
4054 }
4055
4056 /* Check now whether the buffer will become too large,
4057 in the likely case where the file's length is not changing.
4058 This saves a lot of needless work before a buffer overflow. */
4059 if (! not_regular)
4060 {
4061 /* The likely offset where we will stop reading. We could read
4062 more (or less), if the file grows (or shrinks) as we read it. */
4063 off_t likely_end = min (end_offset, st.st_size);
4064
4065 if (beg_offset < likely_end)
4066 {
4067 ptrdiff_t buf_bytes
4068 = Z_BYTE - (!NILP (replace) ? ZV_BYTE - BEGV_BYTE : 0);
4069 ptrdiff_t buf_growth_max = BUF_BYTES_MAX - buf_bytes;
4070 off_t likely_growth = likely_end - beg_offset;
4071 if (buf_growth_max < likely_growth)
4072 buffer_overflow ();
4073 }
4074 }
4075
4076 /* Prevent redisplay optimizations. */
4077 current_buffer->clip_changed = true;
4078
4079 if (EQ (Vcoding_system_for_read, Qauto_save_coding))
4080 {
4081 coding_system = coding_inherit_eol_type (Qutf_8_emacs, Qunix);
4082 setup_coding_system (coding_system, &coding);
4083 /* Ensure we set Vlast_coding_system_used. */
4084 set_coding_system = true;
4085 }
4086 else if (BEG < Z)
4087 {
4088 /* Decide the coding system to use for reading the file now
4089 because we can't use an optimized method for handling
4090 `coding:' tag if the current buffer is not empty. */
4091 if (!NILP (Vcoding_system_for_read))
4092 coding_system = Vcoding_system_for_read;
4093 else
4094 {
4095 /* Don't try looking inside a file for a coding system
4096 specification if it is not seekable. */
4097 if (! not_regular && ! NILP (Vset_auto_coding_function))
4098 {
4099 /* Find a coding system specified in the heading two
4100 lines or in the tailing several lines of the file.
4101 We assume that the 1K-byte and 3K-byte for heading
4102 and tailing respectively are sufficient for this
4103 purpose. */
4104 int nread;
4105
4106 if (st.st_size <= (1024 * 4))
4107 nread = emacs_read_quit (fd, read_buf, 1024 * 4);
4108 else
4109 {
4110 nread = emacs_read_quit (fd, read_buf, 1024);
4111 if (nread == 1024)
4112 {
4113 int ntail;
4114 if (lseek (fd, - (1024 * 3), SEEK_END) < 0)
4115 report_file_error ("Setting file position",
4116 orig_filename);
4117 ntail = emacs_read_quit (fd, read_buf + nread, 1024 * 3);
4118 nread = ntail < 0 ? ntail : nread + ntail;
4119 }
4120 }
4121
4122 if (nread < 0)
4123 report_file_error ("Read error", orig_filename);
4124 else if (nread > 0)
4125 {
4126 AUTO_STRING (name, " *code-converting-work*");
4127 struct buffer *prev = current_buffer;
4128 Lisp_Object workbuf;
4129 struct buffer *buf;
4130
4131 record_unwind_current_buffer ();
4132
4133 workbuf = Fget_buffer_create (name, Qt);
4134 buf = XBUFFER (workbuf);
4135
4136 delete_all_overlays (buf);
4137 bset_directory (buf, BVAR (current_buffer, directory));
4138 bset_read_only (buf, Qnil);
4139 bset_filename (buf, Qnil);
4140 bset_undo_list (buf, Qt);
4141 eassert (buf->overlays_before == NULL);
4142 eassert (buf->overlays_after == NULL);
4143
4144 set_buffer_internal (buf);
4145 Ferase_buffer ();
4146 bset_enable_multibyte_characters (buf, Qnil);
4147
4148 insert_1_both ((char *) read_buf, nread, nread, 0, 0, 0);
4149 TEMP_SET_PT_BOTH (BEG, BEG_BYTE);
4150 coding_system = call2 (Vset_auto_coding_function,
4151 filename, make_fixnum (nread));
4152 set_buffer_internal (prev);
4153
4154 /* Discard the unwind protect for recovering the
4155 current buffer. */
4156 specpdl_ptr--;
4157
4158 /* Rewind the file for the actual read done later. */
4159 if (lseek (fd, 0, SEEK_SET) < 0)
4160 report_file_error ("Setting file position", orig_filename);
4161 }
4162 }
4163
4164 if (NILP (coding_system))
4165 {
4166 /* If we have not yet decided a coding system, check
4167 file-coding-system-alist. */
4168 coding_system = CALLN (Ffind_operation_coding_system,
4169 Qinsert_file_contents, orig_filename,
4170 visit, beg, end, replace);
4171 if (CONSP (coding_system))
4172 coding_system = XCAR (coding_system);
4173 }
4174 }
4175
4176 if (NILP (coding_system))
4177 coding_system = Qundecided;
4178 else
4179 CHECK_CODING_SYSTEM (coding_system);
4180
4181 if (NILP (BVAR (current_buffer, enable_multibyte_characters)))
4182 /* We must suppress all character code conversion except for
4183 end-of-line conversion. */
4184 coding_system = raw_text_coding_system (coding_system);
4185
4186 setup_coding_system (coding_system, &coding);
4187 /* Ensure we set Vlast_coding_system_used. */
4188 set_coding_system = true;
4189 }
4190
4191 /* If requested, replace the accessible part of the buffer
4192 with the file contents. Avoid replacing text at the
4193 beginning or end of the buffer that matches the file contents;
4194 that preserves markers pointing to the unchanged parts.
4195
4196 Here we implement this feature in an optimized way
4197 for the case where code conversion is NOT needed.
4198 The following if-statement handles the case of conversion
4199 in a less optimal way.
4200
4201 If the code conversion is "automatic" then we try using this
4202 method and hope for the best.
4203 But if we discover the need for conversion, we give up on this method
4204 and let the following if-statement handle the replace job. */
4205 if (!NILP (replace)
4206 && BEGV < ZV
4207 && (NILP (coding_system)
4208 || ! CODING_REQUIRE_DECODING (&coding)))
4209 {
4210 ptrdiff_t overlap;
4211 /* There is still a possibility we will find the need to do code
4212 conversion. If that happens, set this variable to
4213 give up on handling REPLACE in the optimized way. */
4214 bool giveup_match_end = false;
4215
4216 if (beg_offset != 0)
4217 {
4218 if (lseek (fd, beg_offset, SEEK_SET) < 0)
4219 report_file_error ("Setting file position", orig_filename);
4220 }
4221
4222 /* Count how many chars at the start of the file
4223 match the text at the beginning of the buffer. */
4224 while (true)
4225 {
4226 int nread = emacs_read_quit (fd, read_buf, sizeof read_buf);
4227 if (nread < 0)
4228 report_file_error ("Read error", orig_filename);
4229 else if (nread == 0)
4230 break;
4231
4232 if (CODING_REQUIRE_DETECTION (&coding))
4233 {
4234 coding_system = detect_coding_system ((unsigned char *) read_buf,
4235 nread, nread, 1, 0,
4236 coding_system);
4237 setup_coding_system (coding_system, &coding);
4238 }
4239
4240 if (CODING_REQUIRE_DECODING (&coding))
4241 /* We found that the file should be decoded somehow.
4242 Let's give up here. */
4243 {
4244 giveup_match_end = true;
4245 break;
4246 }
4247
4248 int bufpos = 0;
4249 while (bufpos < nread && same_at_start < ZV_BYTE
4250 && FETCH_BYTE (same_at_start) == read_buf[bufpos])
4251 same_at_start++, bufpos++;
4252 /* If we found a discrepancy, stop the scan.
4253 Otherwise loop around and scan the next bufferful. */
4254 if (bufpos != nread)
4255 break;
4256 }
4257 /* If the file matches the buffer completely,
4258 there's no need to replace anything. */
4259 if (same_at_start - BEGV_BYTE == end_offset - beg_offset)
4260 {
4261 emacs_close (fd);
4262 clear_unwind_protect (fd_index);
4263
4264 /* Truncate the buffer to the size of the file. */
4265 del_range_1 (same_at_start, same_at_end, 0, 0);
4266 goto handled;
4267 }
4268
4269 /* Count how many chars at the end of the file
4270 match the text at the end of the buffer. But, if we have
4271 already found that decoding is necessary, don't waste time. */
4272 while (!giveup_match_end)
4273 {
4274 int total_read, nread, bufpos, trial;
4275 off_t curpos;
4276
4277 /* At what file position are we now scanning? */
4278 curpos = end_offset - (ZV_BYTE - same_at_end);
4279 /* If the entire file matches the buffer tail, stop the scan. */
4280 if (curpos == 0)
4281 break;
4282 /* How much can we scan in the next step? */
4283 trial = min (curpos, sizeof read_buf);
4284 if (lseek (fd, curpos - trial, SEEK_SET) < 0)
4285 report_file_error ("Setting file position", orig_filename);
4286
4287 total_read = nread = 0;
4288 while (total_read < trial)
4289 {
4290 nread = emacs_read_quit (fd, read_buf + total_read,
4291 trial - total_read);
4292 if (nread < 0)
4293 report_file_error ("Read error", orig_filename);
4294 else if (nread == 0)
4295 break;
4296 total_read += nread;
4297 }
4298
4299 /* Scan this bufferful from the end, comparing with
4300 the Emacs buffer. */
4301 bufpos = total_read;
4302
4303 /* Compare with same_at_start to avoid counting some buffer text
4304 as matching both at the file's beginning and at the end. */
4305 while (bufpos > 0 && same_at_end > same_at_start
4306 && FETCH_BYTE (same_at_end - 1) == read_buf[bufpos - 1])
4307 same_at_end--, bufpos--;
4308
4309 /* If we found a discrepancy, stop the scan.
4310 Otherwise loop around and scan the preceding bufferful. */
4311 if (bufpos != 0)
4312 {
4313 /* If this discrepancy is because of code conversion,
4314 we cannot use this method; giveup and try the other. */
4315 if (same_at_end > same_at_start
4316 && FETCH_BYTE (same_at_end - 1) >= 0200
4317 && ! NILP (BVAR (current_buffer, enable_multibyte_characters))
4318 && (CODING_MAY_REQUIRE_DECODING (&coding)))
4319 giveup_match_end = true;
4320 break;
4321 }
4322
4323 if (nread == 0)
4324 break;
4325 }
4326
4327 if (! giveup_match_end)
4328 {
4329 ptrdiff_t temp;
4330 ptrdiff_t this_count = SPECPDL_INDEX ();
4331
4332 /* We win! We can handle REPLACE the optimized way. */
4333
4334 /* Extend the start of non-matching text area to multibyte
4335 character boundary. */
4336 if (! NILP (BVAR (current_buffer, enable_multibyte_characters)))
4337 while (same_at_start > BEGV_BYTE
4338 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_start)))
4339 same_at_start--;
4340
4341 /* Extend the end of non-matching text area to multibyte
4342 character boundary. */
4343 if (! NILP (BVAR (current_buffer, enable_multibyte_characters)))
4344 while (same_at_end < ZV_BYTE
4345 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_end)))
4346 same_at_end++;
4347
4348 /* Don't try to reuse the same piece of text twice. */
4349 overlap = (same_at_start - BEGV_BYTE
4350 - (same_at_end
4351 + (! NILP (end) ? end_offset : st.st_size) - ZV_BYTE));
4352 if (overlap > 0)
4353 same_at_end += overlap;
4354 same_at_end_charpos = BYTE_TO_CHAR (same_at_end);
4355
4356 /* Arrange to read only the nonmatching middle part of the file. */
4357 beg_offset += same_at_start - BEGV_BYTE;
4358 end_offset -= ZV_BYTE - same_at_end;
4359
4360 /* This binding is to avoid ask-user-about-supersession-threat
4361 being called in insert_from_buffer or del_range_bytes (via
4362 prepare_to_modify_buffer).
4363 AFAICT we could avoid ask-user-about-supersession-threat by setting
4364 current_buffer->modtime earlier, but we could still end up calling
4365 ask-user-about-supersession-threat if the file is modified while
4366 we read it, so we bind buffer-file-name instead. */
4367 specbind (intern ("buffer-file-name"), Qnil);
4368 del_range_byte (same_at_start, same_at_end);
4369 /* Insert from the file at the proper position. */
4370 temp = BYTE_TO_CHAR (same_at_start);
4371 SET_PT_BOTH (temp, same_at_start);
4372 unbind_to (this_count, Qnil);
4373
4374 /* If display currently starts at beginning of line,
4375 keep it that way. */
4376 if (XBUFFER (XWINDOW (selected_window)->contents) == current_buffer)
4377 XWINDOW (selected_window)->start_at_line_beg = !NILP (Fbolp ());
4378
4379 replace_handled = true;
4380 }
4381 }
4382
4383 /* If requested, replace the accessible part of the buffer
4384 with the file contents. Avoid replacing text at the
4385 beginning or end of the buffer that matches the file contents;
4386 that preserves markers pointing to the unchanged parts.
4387
4388 Here we implement this feature for the case where code conversion
4389 is needed, in a simple way that needs a lot of memory.
4390 The preceding if-statement handles the case of no conversion
4391 in a more optimized way. */
4392 if (!NILP (replace) && ! replace_handled && BEGV < ZV)
4393 {
4394 ptrdiff_t same_at_start_charpos;
4395 ptrdiff_t inserted_chars;
4396 ptrdiff_t overlap;
4397 ptrdiff_t bufpos;
4398 unsigned char *decoded;
4399 ptrdiff_t temp;
4400 ptrdiff_t this = 0;
4401 ptrdiff_t this_count = SPECPDL_INDEX ();
4402 bool multibyte
4403 = ! NILP (BVAR (current_buffer, enable_multibyte_characters));
4404 Lisp_Object conversion_buffer;
4405
4406 conversion_buffer = code_conversion_save (1, multibyte);
4407
4408 /* First read the whole file, performing code conversion into
4409 CONVERSION_BUFFER. */
4410
4411 if (lseek (fd, beg_offset, SEEK_SET) < 0)
4412 report_file_error ("Setting file position", orig_filename);
4413
4414 inserted = 0; /* Bytes put into CONVERSION_BUFFER so far. */
4415 unprocessed = 0; /* Bytes not processed in previous loop. */
4416
4417 while (true)
4418 {
4419 /* Read at most READ_BUF_SIZE bytes at a time, to allow
4420 quitting while reading a huge file. */
4421
4422 this = emacs_read_quit (fd, read_buf + unprocessed,
4423 READ_BUF_SIZE - unprocessed);
4424 if (this <= 0)
4425 break;
4426
4427 BUF_TEMP_SET_PT (XBUFFER (conversion_buffer),
4428 BUF_Z (XBUFFER (conversion_buffer)));
4429 decode_coding_c_string (&coding, (unsigned char *) read_buf,
4430 unprocessed + this, conversion_buffer);
4431 unprocessed = coding.carryover_bytes;
4432 if (coding.carryover_bytes > 0)
4433 memcpy (read_buf, coding.carryover, unprocessed);
4434 }
4435
4436 if (this < 0)
4437 report_file_error ("Read error", orig_filename);
4438 emacs_close (fd);
4439 clear_unwind_protect (fd_index);
4440
4441 if (unprocessed > 0)
4442 {
4443 coding.mode |= CODING_MODE_LAST_BLOCK;
4444 decode_coding_c_string (&coding, (unsigned char *) read_buf,
4445 unprocessed, conversion_buffer);
4446 coding.mode &= ~CODING_MODE_LAST_BLOCK;
4447 }
4448
4449 coding_system = CODING_ID_NAME (coding.id);
4450 set_coding_system = true;
4451 maybe_move_gap (XBUFFER (conversion_buffer));
4452 decoded = BUF_BEG_ADDR (XBUFFER (conversion_buffer));
4453 inserted = (BUF_Z_BYTE (XBUFFER (conversion_buffer))
4454 - BUF_BEG_BYTE (XBUFFER (conversion_buffer)));
4455
4456 /* Compare the beginning of the converted string with the buffer
4457 text. */
4458
4459 bufpos = 0;
4460 while (bufpos < inserted && same_at_start < same_at_end
4461 && FETCH_BYTE (same_at_start) == decoded[bufpos])
4462 same_at_start++, bufpos++;
4463
4464 /* If the file matches the head of buffer completely,
4465 there's no need to replace anything. */
4466
4467 if (bufpos == inserted)
4468 {
4469 /* Truncate the buffer to the size of the file. */
4470 if (same_at_start != same_at_end)
4471 {
4472 /* See previous specbind for the reason behind this. */
4473 specbind (intern ("buffer-file-name"), Qnil);
4474 del_range_byte (same_at_start, same_at_end);
4475 }
4476 inserted = 0;
4477
4478 unbind_to (this_count, Qnil);
4479 goto handled;
4480 }
4481
4482 /* Extend the start of non-matching text area to the previous
4483 multibyte character boundary. */
4484 if (! NILP (BVAR (current_buffer, enable_multibyte_characters)))
4485 while (same_at_start > BEGV_BYTE
4486 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_start)))
4487 same_at_start--;
4488
4489 /* Scan this bufferful from the end, comparing with
4490 the Emacs buffer. */
4491 bufpos = inserted;
4492
4493 /* Compare with same_at_start to avoid counting some buffer text
4494 as matching both at the file's beginning and at the end. */
4495 while (bufpos > 0 && same_at_end > same_at_start
4496 && FETCH_BYTE (same_at_end - 1) == decoded[bufpos - 1])
4497 same_at_end--, bufpos--;
4498
4499 /* Extend the end of non-matching text area to the next
4500 multibyte character boundary. */
4501 if (! NILP (BVAR (current_buffer, enable_multibyte_characters)))
4502 while (same_at_end < ZV_BYTE
4503 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_end)))
4504 same_at_end++;
4505
4506 /* Don't try to reuse the same piece of text twice. */
4507 overlap = same_at_start - BEGV_BYTE - (same_at_end + inserted - ZV_BYTE);
4508 if (overlap > 0)
4509 same_at_end += overlap;
4510 same_at_end_charpos = BYTE_TO_CHAR (same_at_end);
4511
4512 /* If display currently starts at beginning of line,
4513 keep it that way. */
4514 if (XBUFFER (XWINDOW (selected_window)->contents) == current_buffer)
4515 XWINDOW (selected_window)->start_at_line_beg = !NILP (Fbolp ());
4516
4517 /* Replace the chars that we need to replace,
4518 and update INSERTED to equal the number of bytes
4519 we are taking from the decoded string. */
4520 inserted -= (ZV_BYTE - same_at_end) + (same_at_start - BEGV_BYTE);
4521
4522 /* See previous specbind for the reason behind this. */
4523 specbind (intern ("buffer-file-name"), Qnil);
4524 if (same_at_end != same_at_start)
4525 {
4526 del_range_byte (same_at_start, same_at_end);
4527 temp = GPT;
4528 eassert (same_at_start == GPT_BYTE);
4529 same_at_start = GPT_BYTE;
4530 }
4531 else
4532 {
4533 temp = same_at_end_charpos;
4534 }
4535 /* Insert from the file at the proper position. */
4536 SET_PT_BOTH (temp, same_at_start);
4537 same_at_start_charpos
4538 = buf_bytepos_to_charpos (XBUFFER (conversion_buffer),
4539 same_at_start - BEGV_BYTE
4540 + BUF_BEG_BYTE (XBUFFER (conversion_buffer)));
4541 eassert (same_at_start_charpos == temp - (BEGV - BEG));
4542 inserted_chars
4543 = (buf_bytepos_to_charpos (XBUFFER (conversion_buffer),
4544 same_at_start + inserted - BEGV_BYTE
4545 + BUF_BEG_BYTE (XBUFFER (conversion_buffer)))
4546 - same_at_start_charpos);
4547 insert_from_buffer (XBUFFER (conversion_buffer),
4548 same_at_start_charpos, inserted_chars, 0);
4549 /* Set `inserted' to the number of inserted characters. */
4550 inserted = PT - temp;
4551 /* Set point before the inserted characters. */
4552 SET_PT_BOTH (temp, same_at_start);
4553
4554 unbind_to (this_count, Qnil);
4555
4556 goto handled;
4557 }
4558
4559 if (! not_regular)
4560 total = end_offset - beg_offset;
4561 else
4562 /* For a special file, all we can do is guess. */
4563 total = READ_BUF_SIZE;
4564
4565 if (NILP (visit) && total > 0)
4566 {
4567 if (!NILP (BVAR (current_buffer, file_truename))
4568 /* Make binding buffer-file-name to nil effective. */
4569 && !NILP (BVAR (current_buffer, filename))
4570 && SAVE_MODIFF >= MODIFF)
4571 we_locked_file = true;
4572 prepare_to_modify_buffer (PT, PT, NULL);
4573 }
4574
4575 move_gap_both (PT, PT_BYTE);
4576 if (GAP_SIZE < total)
4577 make_gap (total - GAP_SIZE);
4578
4579 if (beg_offset != 0 || !NILP (replace))
4580 {
4581 if (lseek (fd, beg_offset, SEEK_SET) < 0)
4582 report_file_error ("Setting file position", orig_filename);
4583 }
4584
4585 /* In the following loop, HOW_MUCH contains the total bytes read so
4586 far for a regular file, and not changed for a special file. But,
4587 before exiting the loop, it is set to a negative value if I/O
4588 error occurs. */
4589 how_much = 0;
4590
4591 /* Total bytes inserted. */
4592 inserted = 0;
4593
4594 /* Here, we don't do code conversion in the loop. It is done by
4595 decode_coding_gap after all data are read into the buffer. */
4596 {
4597 ptrdiff_t gap_size = GAP_SIZE;
4598
4599 while (how_much < total)
4600 {
4601 /* `try' is reserved in some compilers (Microsoft C). */
4602 ptrdiff_t trytry = min (total - how_much, READ_BUF_SIZE);
4603 ptrdiff_t this;
4604
4605 if (not_regular)
4606 {
4607 Lisp_Object nbytes;
4608
4609 /* Maybe make more room. */
4610 if (gap_size < trytry)
4611 {
4612 make_gap (trytry - gap_size);
4613 gap_size = GAP_SIZE - inserted;
4614 }
4615
4616 /* Read from the file, capturing `quit'. When an
4617 error occurs, end the loop, and arrange for a quit
4618 to be signaled after decoding the text we read. */
4619 union read_non_regular data = {{fd, inserted, trytry}};
4620 nbytes = internal_condition_case_1
4621 (read_non_regular, make_pointer_integer (&data),
4622 Qerror, read_non_regular_quit);
4623
4624 if (NILP (nbytes))
4625 {
4626 read_quit = true;
4627 break;
4628 }
4629
4630 this = XFIXNUM (nbytes);
4631 }
4632 else
4633 {
4634 /* Allow quitting out of the actual I/O. We don't make text
4635 part of the buffer until all the reading is done, so a C-g
4636 here doesn't do any harm. */
4637 this = emacs_read_quit (fd,
4638 ((char *) BEG_ADDR + PT_BYTE - BEG_BYTE
4639 + inserted),
4640 trytry);
4641 }
4642
4643 if (this <= 0)
4644 {
4645 how_much = this;
4646 break;
4647 }
4648
4649 gap_size -= this;
4650
4651 /* For a regular file, where TOTAL is the real size,
4652 count HOW_MUCH to compare with it.
4653 For a special file, where TOTAL is just a buffer size,
4654 so don't bother counting in HOW_MUCH.
4655 (INSERTED is where we count the number of characters inserted.) */
4656 if (! not_regular)
4657 how_much += this;
4658 inserted += this;
4659 }
4660 }
4661
4662 /* Now we have either read all the file data into the gap,
4663 or stop reading on I/O error or quit. If nothing was
4664 read, undo marking the buffer modified. */
4665
4666 if (inserted == 0)
4667 {
4668 if (we_locked_file)
4669 Funlock_file (BVAR (current_buffer, file_truename));
4670 Vdeactivate_mark = old_Vdeactivate_mark;
4671 }
4672 else
4673 Fset (Qdeactivate_mark, Qt);
4674
4675 emacs_close (fd);
4676 clear_unwind_protect (fd_index);
4677
4678 if (how_much < 0)
4679 report_file_error ("Read error", orig_filename);
4680
4681 notfound:
4682
4683 if (NILP (coding_system))
4684 {
4685 /* The coding system is not yet decided. Decide it by an
4686 optimized method for handling `coding:' tag.
4687
4688 Note that we can get here only if the buffer was empty
4689 before the insertion. */
4690 eassert (Z == BEG);
4691
4692 if (!NILP (Vcoding_system_for_read))
4693 coding_system = Vcoding_system_for_read;
4694 else
4695 {
4696 /* Since we are sure that the current buffer was empty
4697 before the insertion, we can toggle
4698 enable-multibyte-characters directly here without taking
4699 care of marker adjustment. By this way, we can run Lisp
4700 program safely before decoding the inserted text. */
4701 Lisp_Object multibyte
4702 = BVAR (current_buffer, enable_multibyte_characters);
4703 Lisp_Object unwind_data
4704 = Fcons (multibyte,
4705 Fcons (BVAR (current_buffer, undo_list),
4706 Fcurrent_buffer ()));
4707 ptrdiff_t count1 = SPECPDL_INDEX ();
4708
4709 bset_enable_multibyte_characters (current_buffer, Qnil);
4710 bset_undo_list (current_buffer, Qt);
4711 record_unwind_protect (decide_coding_unwind, unwind_data);
4712
4713 /* Make the text read part of the buffer. */
4714 insert_from_gap_1 (inserted, inserted, false);
4715
4716 if (inserted > 0 && ! NILP (Vset_auto_coding_function))
4717 {
4718 coding_system = call2 (Vset_auto_coding_function,
4719 filename, make_fixnum (inserted));
4720 }
4721
4722 if (NILP (coding_system))
4723 {
4724 /* If the coding system is not yet decided, check
4725 file-coding-system-alist. */
4726 coding_system = CALLN (Ffind_operation_coding_system,
4727 Qinsert_file_contents, orig_filename,
4728 visit, beg, end, Qnil);
4729 if (CONSP (coding_system))
4730 coding_system = XCAR (coding_system);
4731 }
4732 /* Move the text back to the gap. */
4733 unbind_to (count1, Qnil);
4734 inserted = XFIXNUM (XCAR (unwind_data));
4735 }
4736
4737 if (NILP (coding_system))
4738 coding_system = Qundecided;
4739 else
4740 CHECK_CODING_SYSTEM (coding_system);
4741
4742 if (NILP (BVAR (current_buffer, enable_multibyte_characters)))
4743 /* We must suppress all character code conversion except for
4744 end-of-line conversion. */
4745 coding_system = raw_text_coding_system (coding_system);
4746 setup_coding_system (coding_system, &coding);
4747 /* Ensure we set Vlast_coding_system_used. */
4748 set_coding_system = true;
4749 }
4750
4751 if (!NILP (visit))
4752 {
4753 /* When we visit a file by raw-text, we change the buffer to
4754 unibyte. */
4755 if (CODING_FOR_UNIBYTE (&coding)
4756 /* Can't do this if part of the buffer might be preserved. */
4757 && NILP (replace))
4758 {
4759 /* Visiting a file with these coding system makes the buffer
4760 unibyte. */
4761 if (inserted > 0)
4762 bset_enable_multibyte_characters (current_buffer, Qnil);
4763 else
4764 Fset_buffer_multibyte (Qnil);
4765 }
4766 }
4767
4768 eassert (PT == GPT);
4769
4770 coding.dst_multibyte
4771 = !NILP (BVAR (current_buffer, enable_multibyte_characters));
4772 if (CODING_MAY_REQUIRE_DECODING (&coding)
4773 && (inserted > 0 || CODING_REQUIRE_FLUSHING (&coding)))
4774 {
4775 /* Now we have all the new bytes at the beginning of the gap,
4776 but `decode_coding_gap` can't have them at the beginning of the gap,
4777 so we need to move them. */
4778 memmove (GAP_END_ADDR - inserted, GPT_ADDR, inserted);
4779 decode_coding_gap (&coding, inserted);
4780 inserted = coding.produced_char;
4781 coding_system = CODING_ID_NAME (coding.id);
4782 }
4783 else if (inserted > 0)
4784 {
4785 /* Make the text read part of the buffer. */
4786 eassert (NILP (BVAR (current_buffer, enable_multibyte_characters)));
4787 insert_from_gap_1 (inserted, inserted, false);
4788
4789 invalidate_buffer_caches (current_buffer, PT, PT + inserted);
4790 adjust_after_insert (PT, PT_BYTE, PT + inserted, PT_BYTE + inserted,
4791 inserted);
4792 }
4793
4794 /* Call after-change hooks for the inserted text, aside from the case
4795 of normal visiting (not with REPLACE), which is done in a new buffer
4796 "before" the buffer is changed. */
4797 if (inserted > 0 && total > 0
4798 && (NILP (visit) || !NILP (replace)))
4799 {
4800 signal_after_change (PT, 0, inserted);
4801 update_compositions (PT, PT, CHECK_BORDER);
4802 }
4803
4804 /* Now INSERTED is measured in characters. */
4805
4806 handled:
4807
4808 if (inserted > 0)
4809 restore_window_points (window_markers, inserted,
4810 BYTE_TO_CHAR (same_at_start),
4811 same_at_end_charpos);
4812
4813 if (!NILP (visit))
4814 {
4815 if (empty_undo_list_p)
4816 bset_undo_list (current_buffer, Qnil);
4817
4818 if (NILP (handler))
4819 {
4820 current_buffer->modtime = mtime;
4821 current_buffer->modtime_size = st.st_size;
4822 bset_filename (current_buffer, orig_filename);
4823 }
4824
4825 SAVE_MODIFF = MODIFF;
4826 BUF_AUTOSAVE_MODIFF (current_buffer) = MODIFF;
4827 XSETFASTINT (BVAR (current_buffer, save_length), Z - BEG);
4828 if (NILP (handler))
4829 {
4830 if (!NILP (BVAR (current_buffer, file_truename)))
4831 Funlock_file (BVAR (current_buffer, file_truename));
4832 Funlock_file (filename);
4833 }
4834 if (not_regular)
4835 xsignal2 (Qfile_error,
4836 build_string ("not a regular file"), orig_filename);
4837 }
4838
4839 if (set_coding_system)
4840 Vlast_coding_system_used = coding_system;
4841
4842 if (! NILP (Ffboundp (Qafter_insert_file_set_coding)))
4843 {
4844 insval = call2 (Qafter_insert_file_set_coding, make_fixnum (inserted),
4845 visit);
4846 if (! NILP (insval))
4847 {
4848 if (! RANGED_FIXNUMP (0, insval, ZV - PT))
4849 wrong_type_argument (intern ("inserted-chars"), insval);
4850 inserted = XFIXNAT (insval);
4851 }
4852 }
4853
4854 /* Decode file format. */
4855 if (inserted > 0)
4856 {
4857 /* Don't run point motion or modification hooks when decoding. */
4858 ptrdiff_t count1 = SPECPDL_INDEX ();
4859 ptrdiff_t old_inserted = inserted;
4860 specbind (Qinhibit_point_motion_hooks, Qt);
4861 specbind (Qinhibit_modification_hooks, Qt);
4862
4863 /* Save old undo list and don't record undo for decoding. */
4864 old_undo = BVAR (current_buffer, undo_list);
4865 bset_undo_list (current_buffer, Qt);
4866
4867 if (NILP (replace))
4868 {
4869 insval = call3 (Qformat_decode,
4870 Qnil, make_fixnum (inserted), visit);
4871 if (! RANGED_FIXNUMP (0, insval, ZV - PT))
4872 wrong_type_argument (intern ("inserted-chars"), insval);
4873 inserted = XFIXNAT (insval);
4874 }
4875 else
4876 {
4877 /* If REPLACE is non-nil and we succeeded in not replacing the
4878 beginning or end of the buffer text with the file's contents,
4879 call format-decode with `point' positioned at the beginning
4880 of the buffer and `inserted' equaling the number of
4881 characters in the buffer. Otherwise, format-decode might
4882 fail to correctly analyze the beginning or end of the buffer.
4883 Hence we temporarily save `point' and `inserted' here and
4884 restore `point' iff format-decode did not insert or delete
4885 any text. Otherwise we leave `point' at point-min. */
4886 ptrdiff_t opoint = PT;
4887 ptrdiff_t opoint_byte = PT_BYTE;
4888 ptrdiff_t oinserted = ZV - BEGV;
4889 modiff_count ochars_modiff = CHARS_MODIFF;
4890
4891 TEMP_SET_PT_BOTH (BEGV, BEGV_BYTE);
4892 insval = call3 (Qformat_decode,
4893 Qnil, make_fixnum (oinserted), visit);
4894 if (! RANGED_FIXNUMP (0, insval, ZV - PT))
4895 wrong_type_argument (intern ("inserted-chars"), insval);
4896 if (ochars_modiff == CHARS_MODIFF)
4897 /* format_decode didn't modify buffer's characters => move
4898 point back to position before inserted text and leave
4899 value of inserted alone. */
4900 SET_PT_BOTH (opoint, opoint_byte);
4901 else
4902 /* format_decode modified buffer's characters => consider
4903 entire buffer changed and leave point at point-min. */
4904 inserted = XFIXNAT (insval);
4905 }
4906
4907 /* For consistency with format-decode call these now iff inserted > 0
4908 (martin 2007-06-28). */
4909 p = Vafter_insert_file_functions;
FOR_EACH_TAIL(p)4910 FOR_EACH_TAIL (p)
4911 {
4912 if (NILP (replace))
4913 {
4914 insval = call1 (XCAR (p), make_fixnum (inserted));
4915 if (!NILP (insval))
4916 {
4917 if (! RANGED_FIXNUMP (0, insval, ZV - PT))
4918 wrong_type_argument (intern ("inserted-chars"), insval);
4919 inserted = XFIXNAT (insval);
4920 }
4921 }
4922 else
4923 {
4924 /* For the rationale of this see the comment on
4925 format-decode above. */
4926 ptrdiff_t opoint = PT;
4927 ptrdiff_t opoint_byte = PT_BYTE;
4928 ptrdiff_t oinserted = ZV - BEGV;
4929 modiff_count ochars_modiff = CHARS_MODIFF;
4930
4931 TEMP_SET_PT_BOTH (BEGV, BEGV_BYTE);
4932 insval = call1 (XCAR (p), make_fixnum (oinserted));
4933 if (!NILP (insval))
4934 {
4935 if (! RANGED_FIXNUMP (0, insval, ZV - PT))
4936 wrong_type_argument (intern ("inserted-chars"), insval);
4937 if (ochars_modiff == CHARS_MODIFF)
4938 /* after_insert_file_functions didn't modify
4939 buffer's characters => move point back to
4940 position before inserted text and leave value of
4941 inserted alone. */
4942 SET_PT_BOTH (opoint, opoint_byte);
4943 else
4944 /* after_insert_file_functions did modify buffer's
4945 characters => consider entire buffer changed and
4946 leave point at point-min. */
4947 inserted = XFIXNAT (insval);
4948 }
4949 }
4950 }
4951
4952 if (!empty_undo_list_p)
4953 {
4954 bset_undo_list (current_buffer, old_undo);
4955 if (CONSP (old_undo) && inserted != old_inserted)
4956 {
4957 /* Adjust the last undo record for the size change during
4958 the format conversion. */
4959 Lisp_Object tem = XCAR (old_undo);
4960 if (CONSP (tem) && FIXNUMP (XCAR (tem))
4961 && FIXNUMP (XCDR (tem))
4962 && XFIXNUM (XCDR (tem)) == PT + old_inserted)
4963 XSETCDR (tem, make_fixnum (PT + inserted));
4964 }
4965 }
4966 else
4967 /* If undo_list was Qt before, keep it that way.
4968 Otherwise start with an empty undo_list. */
4969 bset_undo_list (current_buffer, EQ (old_undo, Qt) ? Qt : Qnil);
4970
4971 unbind_to (count1, Qnil);
4972 }
4973
4974 if (!NILP (visit) && current_buffer->modtime.tv_nsec < 0)
4975 {
4976 /* Signal an error if visiting a file that could not be opened. */
4977 report_file_errno ("Opening input file", orig_filename, save_errno);
4978 }
4979
4980 /* We made a lot of deletions and insertions above, so invalidate
4981 the newline cache for the entire region of the inserted
4982 characters. */
4983 if (current_buffer->base_buffer && current_buffer->base_buffer->newline_cache)
4984 invalidate_region_cache (current_buffer->base_buffer,
4985 current_buffer->base_buffer->newline_cache,
4986 PT - BEG, Z - PT - inserted);
4987 else if (current_buffer->newline_cache)
4988 invalidate_region_cache (current_buffer,
4989 current_buffer->newline_cache,
4990 PT - BEG, Z - PT - inserted);
4991
4992 if (read_quit)
4993 quit ();
4994
4995 /* Retval needs to be dealt with in all cases consistently. */
4996 if (NILP (val))
4997 val = list2 (orig_filename, make_fixnum (inserted));
4998
4999 return unbind_to (count, val);
5000 }
5001
5002 static Lisp_Object build_annotations (Lisp_Object, Lisp_Object);
5003
5004 static void
build_annotations_unwind(Lisp_Object arg)5005 build_annotations_unwind (Lisp_Object arg)
5006 {
5007 Vwrite_region_annotation_buffers = arg;
5008 }
5009
5010 /* Decide the coding-system to encode the data with. */
5011
5012 static Lisp_Object
choose_write_coding_system(Lisp_Object start,Lisp_Object end,Lisp_Object filename,Lisp_Object append,Lisp_Object visit,Lisp_Object lockname,struct coding_system * coding)5013 choose_write_coding_system (Lisp_Object start, Lisp_Object end, Lisp_Object filename,
5014 Lisp_Object append, Lisp_Object visit, Lisp_Object lockname,
5015 struct coding_system *coding)
5016 {
5017 Lisp_Object val;
5018 Lisp_Object eol_parent = Qnil;
5019
5020 if (auto_saving
5021 && NILP (Fstring_equal (BVAR (current_buffer, filename),
5022 BVAR (current_buffer, auto_save_file_name))))
5023 {
5024 val = Qutf_8_emacs;
5025 eol_parent = Qunix;
5026 }
5027 else if (!NILP (Vcoding_system_for_write))
5028 {
5029 val = Vcoding_system_for_write;
5030 if (coding_system_require_warning
5031 && !NILP (Ffboundp (Vselect_safe_coding_system_function)))
5032 /* Confirm that VAL can surely encode the current region. */
5033 val = call5 (Vselect_safe_coding_system_function,
5034 start, end, list2 (Qt, val),
5035 Qnil, filename);
5036 }
5037 else
5038 {
5039 /* If the variable `buffer-file-coding-system' is set locally,
5040 it means that the file was read with some kind of code
5041 conversion or the variable is explicitly set by users. We
5042 had better write it out with the same coding system even if
5043 `enable-multibyte-characters' is nil.
5044
5045 If it is not set locally, we anyway have to convert EOL
5046 format if the default value of `buffer-file-coding-system'
5047 tells that it is not Unix-like (LF only) format. */
5048 bool using_default_coding = 0;
5049 bool force_raw_text = 0;
5050
5051 val = BVAR (current_buffer, buffer_file_coding_system);
5052 if (NILP (val)
5053 || NILP (Flocal_variable_p (Qbuffer_file_coding_system, Qnil)))
5054 {
5055 val = Qnil;
5056 if (NILP (BVAR (current_buffer, enable_multibyte_characters)))
5057 force_raw_text = 1;
5058 }
5059
5060 if (NILP (val))
5061 {
5062 /* Check file-coding-system-alist. */
5063 Lisp_Object coding_systems
5064 = CALLN (Ffind_operation_coding_system, Qwrite_region, start, end,
5065 filename, append, visit, lockname);
5066 if (CONSP (coding_systems) && !NILP (XCDR (coding_systems)))
5067 val = XCDR (coding_systems);
5068 }
5069
5070 if (NILP (val))
5071 {
5072 /* If we still have not decided a coding system, use the
5073 current buffer's value of buffer-file-coding-system. */
5074 val = BVAR (current_buffer, buffer_file_coding_system);
5075 using_default_coding = 1;
5076 }
5077
5078 if (! NILP (val) && ! force_raw_text)
5079 {
5080 Lisp_Object spec, attrs;
5081
5082 CHECK_CODING_SYSTEM (val);
5083 CHECK_CODING_SYSTEM_GET_SPEC (val, spec);
5084 attrs = AREF (spec, 0);
5085 if (EQ (CODING_ATTR_TYPE (attrs), Qraw_text))
5086 force_raw_text = 1;
5087 }
5088
5089 if (!force_raw_text
5090 && !NILP (Ffboundp (Vselect_safe_coding_system_function)))
5091 {
5092 /* Confirm that VAL can surely encode the current region. */
5093 val = call5 (Vselect_safe_coding_system_function,
5094 start, end, val, Qnil, filename);
5095 /* As the function specified by select-safe-coding-system-function
5096 is out of our control, make sure we are not fed by bogus
5097 values. */
5098 if (!NILP (val))
5099 CHECK_CODING_SYSTEM (val);
5100 }
5101
5102 /* If the decided coding-system doesn't specify end-of-line
5103 format, we use that of `buffer-file-coding-system'. */
5104 if (! using_default_coding)
5105 {
5106 Lisp_Object dflt = BVAR (&buffer_defaults, buffer_file_coding_system);
5107
5108 if (! NILP (dflt))
5109 val = coding_inherit_eol_type (val, dflt);
5110 }
5111
5112 /* If we decide not to encode text, use `raw-text' or one of its
5113 subsidiaries. */
5114 if (force_raw_text)
5115 val = raw_text_coding_system (val);
5116 }
5117
5118 val = coding_inherit_eol_type (val, eol_parent);
5119 setup_coding_system (val, coding);
5120
5121 if (!STRINGP (start) && EQ (Qt, BVAR (current_buffer, selective_display)))
5122 coding->mode |= CODING_MODE_SELECTIVE_DISPLAY;
5123 return val;
5124 }
5125
5126 DEFUN ("write-region", Fwrite_region, Swrite_region, 3, 7,
5127 "r\nFWrite region to file: \ni\ni\ni\np",
5128 doc: /* Write current region into specified file.
5129 When called from a program, requires three arguments:
5130 START, END and FILENAME. START and END are normally buffer positions
5131 specifying the part of the buffer to write.
5132 If START is nil, that means to use the entire buffer contents; END is
5133 ignored.
5134 If START is a string, then output that string to the file
5135 instead of any buffer contents; END is ignored.
5136
5137 Optional fourth argument APPEND if non-nil means
5138 append to existing file contents (if any). If it is a number,
5139 seek to that offset in the file before writing.
5140 Optional fifth argument VISIT, if t or a string, means
5141 set the last-save-file-modtime of buffer to this file's modtime
5142 and mark buffer not modified.
5143 If VISIT is t, the buffer is marked as visiting FILENAME.
5144 If VISIT is a string, it is a second file name;
5145 the output goes to FILENAME, but the buffer is marked as visiting VISIT.
5146 VISIT is also the file name to lock and unlock for clash detection.
5147 If VISIT is neither t nor nil nor a string, or if Emacs is in batch mode,
5148 do not display the \"Wrote file\" message.
5149 The optional sixth arg LOCKNAME, if non-nil, specifies the name to
5150 use for locking and unlocking, overriding FILENAME and VISIT.
5151 The optional seventh arg MUSTBENEW, if non-nil, insists on a check
5152 for an existing file with the same name. If MUSTBENEW is `excl',
5153 that means to get an error if the file already exists; never overwrite.
5154 If MUSTBENEW is neither nil nor `excl', that means ask for
5155 confirmation before overwriting, but do go ahead and overwrite the file
5156 if the user confirms.
5157
5158 This does code conversion according to the value of
5159 `coding-system-for-write', `buffer-file-coding-system', or
5160 `file-coding-system-alist', and sets the variable
5161 `last-coding-system-used' to the coding system actually used.
5162
5163 This calls `write-region-annotate-functions' at the start, and
5164 `write-region-post-annotation-function' at the end. */)
5165 (Lisp_Object start, Lisp_Object end, Lisp_Object filename, Lisp_Object append,
5166 Lisp_Object visit, Lisp_Object lockname, Lisp_Object mustbenew)
5167 {
5168 return write_region (start, end, filename, append, visit, lockname, mustbenew,
5169 -1);
5170 }
5171
5172 /* Like Fwrite_region, except that if DESC is nonnegative, it is a file
5173 descriptor for FILENAME, so do not open or close FILENAME. */
5174
5175 Lisp_Object
write_region(Lisp_Object start,Lisp_Object end,Lisp_Object filename,Lisp_Object append,Lisp_Object visit,Lisp_Object lockname,Lisp_Object mustbenew,int desc)5176 write_region (Lisp_Object start, Lisp_Object end, Lisp_Object filename,
5177 Lisp_Object append, Lisp_Object visit, Lisp_Object lockname,
5178 Lisp_Object mustbenew, int desc)
5179 {
5180 int open_flags;
5181 int mode;
5182 off_t offset UNINIT;
5183 bool open_and_close_file = desc < 0;
5184 bool ok;
5185 int save_errno = 0;
5186 const char *fn;
5187 struct stat st;
5188 struct timespec modtime;
5189 ptrdiff_t count = SPECPDL_INDEX ();
5190 ptrdiff_t count1 UNINIT;
5191 Lisp_Object handler;
5192 Lisp_Object visit_file;
5193 Lisp_Object annotations;
5194 Lisp_Object encoded_filename;
5195 bool visiting = (EQ (visit, Qt) || STRINGP (visit));
5196 bool quietly = !NILP (visit);
5197 bool file_locked = 0;
5198 struct buffer *given_buffer;
5199 struct coding_system coding;
5200
5201 if (current_buffer->base_buffer && visiting)
5202 error ("Cannot do file visiting in an indirect buffer");
5203
5204 if (!NILP (start) && !STRINGP (start))
5205 validate_region (&start, &end);
5206
5207 visit_file = Qnil;
5208
5209 filename = Fexpand_file_name (filename, Qnil);
5210
5211 if (!NILP (mustbenew) && !EQ (mustbenew, Qexcl))
5212 barf_or_query_if_file_exists (filename, false, "overwrite", true, true);
5213
5214 if (STRINGP (visit))
5215 visit_file = Fexpand_file_name (visit, Qnil);
5216 else
5217 visit_file = filename;
5218
5219 if (NILP (lockname))
5220 lockname = visit_file;
5221
5222 annotations = Qnil;
5223
5224 /* If the file name has special constructs in it,
5225 call the corresponding file name handler. */
5226 handler = Ffind_file_name_handler (filename, Qwrite_region);
5227 /* If FILENAME has no handler, see if VISIT has one. */
5228 if (NILP (handler) && STRINGP (visit))
5229 handler = Ffind_file_name_handler (visit, Qwrite_region);
5230
5231 if (!NILP (handler))
5232 {
5233 Lisp_Object val;
5234 val = call8 (handler, Qwrite_region, start, end,
5235 filename, append, visit, lockname, mustbenew);
5236
5237 if (visiting)
5238 {
5239 SAVE_MODIFF = MODIFF;
5240 XSETFASTINT (BVAR (current_buffer, save_length), Z - BEG);
5241 bset_filename (current_buffer, visit_file);
5242 }
5243
5244 return val;
5245 }
5246
5247 record_unwind_protect (save_restriction_restore, save_restriction_save ());
5248
5249 /* Special kludge to simplify auto-saving. */
5250 if (NILP (start))
5251 {
5252 /* Do it later, so write-region-annotate-function can work differently
5253 if we save "the buffer" vs "a region".
5254 This is useful in tar-mode. --Stef
5255 XSETFASTINT (start, BEG);
5256 XSETFASTINT (end, Z); */
5257 Fwiden ();
5258 }
5259
5260 record_unwind_protect (build_annotations_unwind,
5261 Vwrite_region_annotation_buffers);
5262 Vwrite_region_annotation_buffers = list1 (Fcurrent_buffer ());
5263
5264 given_buffer = current_buffer;
5265
5266 if (!STRINGP (start))
5267 {
5268 annotations = build_annotations (start, end);
5269
5270 if (current_buffer != given_buffer)
5271 {
5272 XSETFASTINT (start, BEGV);
5273 XSETFASTINT (end, ZV);
5274 }
5275 }
5276
5277 if (NILP (start))
5278 {
5279 XSETFASTINT (start, BEGV);
5280 XSETFASTINT (end, ZV);
5281 }
5282
5283 /* Decide the coding-system to encode the data with.
5284 We used to make this choice before calling build_annotations, but that
5285 leads to problems when a write-annotate-function takes care of
5286 unsavable chars (as was the case with X-Symbol). */
5287 Vlast_coding_system_used
5288 = choose_write_coding_system (start, end, filename,
5289 append, visit, lockname, &coding);
5290
5291 if (open_and_close_file && !auto_saving)
5292 {
5293 Flock_file (lockname);
5294 file_locked = 1;
5295 }
5296
5297 encoded_filename = ENCODE_FILE (filename);
5298 fn = SSDATA (encoded_filename);
5299 open_flags = O_WRONLY | O_CREAT;
5300 open_flags |= EQ (mustbenew, Qexcl) ? O_EXCL : !NILP (append) ? 0 : O_TRUNC;
5301 if (NUMBERP (append))
5302 offset = file_offset (append);
5303 else if (!NILP (append))
5304 open_flags |= O_APPEND;
5305 #ifdef DOS_NT
5306 mode = S_IREAD | S_IWRITE;
5307 #else
5308 mode = auto_saving ? auto_save_mode_bits : 0666;
5309 #endif
5310
5311 if (open_and_close_file)
5312 {
5313 desc = emacs_open (fn, open_flags, mode);
5314 if (desc < 0)
5315 {
5316 int open_errno = errno;
5317 if (file_locked)
5318 Funlock_file (lockname);
5319 report_file_errno ("Opening output file", filename, open_errno);
5320 }
5321
5322 count1 = SPECPDL_INDEX ();
5323 record_unwind_protect_int (close_file_unwind, desc);
5324 }
5325
5326 if (NUMBERP (append))
5327 {
5328 off_t ret = lseek (desc, offset, SEEK_SET);
5329 if (ret < 0)
5330 {
5331 int lseek_errno = errno;
5332 if (file_locked)
5333 Funlock_file (lockname);
5334 report_file_errno ("Lseek error", filename, lseek_errno);
5335 }
5336 }
5337
5338 if (STRINGP (start))
5339 ok = a_write (desc, start, 0, SCHARS (start), &annotations, &coding);
5340 else if (XFIXNUM (start) != XFIXNUM (end))
5341 ok = a_write (desc, Qnil, XFIXNUM (start), XFIXNUM (end) - XFIXNUM (start),
5342 &annotations, &coding);
5343 else
5344 {
5345 /* If file was empty, still need to write the annotations. */
5346 coding.mode |= CODING_MODE_LAST_BLOCK;
5347 ok = a_write (desc, Qnil, XFIXNUM (end), 0, &annotations, &coding);
5348 }
5349 save_errno = errno;
5350
5351 if (ok && CODING_REQUIRE_FLUSHING (&coding)
5352 && !(coding.mode & CODING_MODE_LAST_BLOCK))
5353 {
5354 /* We have to flush out a data. */
5355 coding.mode |= CODING_MODE_LAST_BLOCK;
5356 ok = e_write (desc, Qnil, 1, 1, &coding);
5357 save_errno = errno;
5358 }
5359
5360 /* fsync is not crucial for temporary files. Nor for auto-save
5361 files, since they might lose some work anyway. */
5362 if (open_and_close_file && !auto_saving && !write_region_inhibit_fsync)
5363 {
5364 /* Transfer data and metadata to disk, retrying if interrupted.
5365 fsync can report a write failure here, e.g., due to disk full
5366 under NFS. But ignore EINVAL, which means fsync is not
5367 supported on this file. */
5368 while (fsync (desc) != 0)
5369 if (errno != EINTR)
5370 {
5371 if (errno != EINVAL)
5372 ok = 0, save_errno = errno;
5373 break;
5374 }
5375 }
5376
5377 modtime = invalid_timespec ();
5378 if (visiting)
5379 {
5380 if (fstat (desc, &st) == 0)
5381 modtime = get_stat_mtime (&st);
5382 else
5383 ok = 0, save_errno = errno;
5384 }
5385
5386 if (open_and_close_file)
5387 {
5388 /* NFS can report a write failure now. */
5389 if (emacs_close (desc) < 0)
5390 ok = 0, save_errno = errno;
5391
5392 /* Discard the unwind protect for close_file_unwind. */
5393 specpdl_ptr = specpdl + count1;
5394 }
5395
5396 /* Some file systems have a bug where st_mtime is not updated
5397 properly after a write. For example, CIFS might not see the
5398 st_mtime change until after the file is opened again.
5399
5400 Attempt to detect this file system bug, and update MODTIME to the
5401 newer st_mtime if the bug appears to be present. This introduces
5402 a race condition, so to avoid most instances of the race condition
5403 on non-buggy file systems, skip this check if the most recently
5404 encountered non-buggy file system was the current file system.
5405
5406 A race condition can occur if some other process modifies the
5407 file between the fstat above and the fstat below, but the race is
5408 unlikely and a similar race between the last write and the fstat
5409 above cannot possibly be closed anyway. */
5410
5411 if (timespec_valid_p (modtime)
5412 && ! (valid_timestamp_file_system && st.st_dev == timestamp_file_system))
5413 {
5414 int desc1 = emacs_open (fn, O_WRONLY, 0);
5415 if (desc1 >= 0)
5416 {
5417 struct stat st1;
5418 if (fstat (desc1, &st1) == 0
5419 && st.st_dev == st1.st_dev && st.st_ino == st1.st_ino)
5420 {
5421 /* Use the heuristic if it appears to be valid. With neither
5422 O_EXCL nor O_TRUNC, if Emacs happened to write nothing to the
5423 file, the time stamp won't change. Also, some non-POSIX
5424 systems don't update an empty file's time stamp when
5425 truncating it. Finally, file systems with 100 ns or worse
5426 resolution sometimes seem to have bugs: on a system with ns
5427 resolution, checking ns % 100 incorrectly avoids the heuristic
5428 1% of the time, but the problem should be temporary as we will
5429 try again on the next time stamp. */
5430 bool use_heuristic
5431 = ((open_flags & (O_EXCL | O_TRUNC)) != 0
5432 && st.st_size != 0
5433 && modtime.tv_nsec % 100 != 0);
5434
5435 struct timespec modtime1 = get_stat_mtime (&st1);
5436 if (use_heuristic
5437 && timespec_cmp (modtime, modtime1) == 0
5438 && st.st_size == st1.st_size)
5439 {
5440 timestamp_file_system = st.st_dev;
5441 valid_timestamp_file_system = 1;
5442 }
5443 else
5444 {
5445 st.st_size = st1.st_size;
5446 modtime = modtime1;
5447 }
5448 }
5449 emacs_close (desc1);
5450 }
5451 }
5452
5453 /* Call write-region-post-annotation-function. */
5454 while (CONSP (Vwrite_region_annotation_buffers))
5455 {
5456 Lisp_Object buf = XCAR (Vwrite_region_annotation_buffers);
5457 if (!NILP (Fbuffer_live_p (buf)))
5458 {
5459 Fset_buffer (buf);
5460 if (FUNCTIONP (Vwrite_region_post_annotation_function))
5461 call0 (Vwrite_region_post_annotation_function);
5462 }
5463 Vwrite_region_annotation_buffers
5464 = XCDR (Vwrite_region_annotation_buffers);
5465 }
5466
5467 unbind_to (count, Qnil);
5468
5469 if (file_locked)
5470 Funlock_file (lockname);
5471
5472 /* Do this before reporting IO error
5473 to avoid a "file has changed on disk" warning on
5474 next attempt to save. */
5475 if (timespec_valid_p (modtime))
5476 {
5477 current_buffer->modtime = modtime;
5478 current_buffer->modtime_size = st.st_size;
5479 }
5480
5481 if (! ok)
5482 report_file_errno ("Write error", filename, save_errno);
5483
5484 bool auto_saving_into_visited_file =
5485 auto_saving
5486 && ! NILP (Fstring_equal (BVAR (current_buffer, filename),
5487 BVAR (current_buffer, auto_save_file_name)));
5488 if (visiting)
5489 {
5490 SAVE_MODIFF = MODIFF;
5491 XSETFASTINT (BVAR (current_buffer, save_length), Z - BEG);
5492 bset_filename (current_buffer, visit_file);
5493 update_mode_lines = 14;
5494 if (auto_saving_into_visited_file)
5495 Funlock_file (lockname);
5496 }
5497 else if (quietly)
5498 {
5499 if (auto_saving_into_visited_file)
5500 {
5501 SAVE_MODIFF = MODIFF;
5502 Funlock_file (lockname);
5503 }
5504
5505 return Qnil;
5506 }
5507
5508 if (!auto_saving && !noninteractive)
5509 message_with_string ((NUMBERP (append)
5510 ? "Updated %s"
5511 : ! NILP (append)
5512 ? "Added to %s"
5513 : "Wrote %s"),
5514 visit_file, 1);
5515
5516 return Qnil;
5517 }
5518
5519 DEFUN ("car-less-than-car", Fcar_less_than_car, Scar_less_than_car, 2, 2, 0,
5520 doc: /* Return t if (car A) is numerically less than (car B). */)
5521 (Lisp_Object a, Lisp_Object b)
5522 {
5523 return arithcompare (Fcar (a), Fcar (b), ARITH_LESS);
5524 }
5525
5526 /* Build the complete list of annotations appropriate for writing out
5527 the text between START and END, by calling all the functions in
5528 write-region-annotate-functions and merging the lists they return.
5529 If one of these functions switches to a different buffer, we assume
5530 that buffer contains altered text. Therefore, the caller must
5531 make sure to restore the current buffer in all cases,
5532 as save-excursion would do. */
5533
5534 static Lisp_Object
build_annotations(Lisp_Object start,Lisp_Object end)5535 build_annotations (Lisp_Object start, Lisp_Object end)
5536 {
5537 Lisp_Object annotations;
5538 Lisp_Object p, res;
5539 Lisp_Object original_buffer;
5540 bool used_global = false;
5541
5542 XSETBUFFER (original_buffer, current_buffer);
5543
5544 annotations = Qnil;
5545 p = Vwrite_region_annotate_functions;
5546 loop_over_p:
5547 FOR_EACH_TAIL (p)
5548 {
5549 struct buffer *given_buffer = current_buffer;
5550 if (EQ (Qt, XCAR (p)) && !used_global)
5551 { /* Use the global value of the hook. */
5552 used_global = true;
5553 p = CALLN (Fappend,
5554 Fdefault_value (Qwrite_region_annotate_functions),
5555 XCDR (p));
5556 goto loop_over_p;
5557 }
5558 Vwrite_region_annotations_so_far = annotations;
5559 res = call2 (XCAR (p), start, end);
5560 /* If the function makes a different buffer current,
5561 assume that means this buffer contains altered text to be output.
5562 Reset START and END from the buffer bounds
5563 and discard all previous annotations because they should have
5564 been dealt with by this function. */
5565 if (current_buffer != given_buffer)
5566 {
5567 Vwrite_region_annotation_buffers
5568 = Fcons (Fcurrent_buffer (),
5569 Vwrite_region_annotation_buffers);
5570 XSETFASTINT (start, BEGV);
5571 XSETFASTINT (end, ZV);
5572 annotations = Qnil;
5573 }
5574 Flength (res); /* Check basic validity of return value */
5575 annotations = merge (annotations, res, Qcar_less_than_car);
5576 }
5577
5578 /* Now do the same for annotation functions implied by the file-format */
5579 if (auto_saving && (!EQ (BVAR (current_buffer, auto_save_file_format), Qt)))
5580 p = BVAR (current_buffer, auto_save_file_format);
5581 else
5582 p = BVAR (current_buffer, file_format);
5583 EMACS_INT i = 0;
5584 FOR_EACH_TAIL (p)
5585 {
5586 struct buffer *given_buffer = current_buffer;
5587
5588 Vwrite_region_annotations_so_far = annotations;
5589
5590 /* Value is either a list of annotations or nil if the function
5591 has written annotations to a temporary buffer, which is now
5592 current. */
5593 res = call5 (Qformat_annotate_function, XCAR (p), start, end,
5594 original_buffer, make_fixnum (i++));
5595 if (current_buffer != given_buffer)
5596 {
5597 XSETFASTINT (start, BEGV);
5598 XSETFASTINT (end, ZV);
5599 annotations = Qnil;
5600 }
5601
5602 if (CONSP (res))
5603 annotations = merge (annotations, res, Qcar_less_than_car);
5604 }
5605
5606 return annotations;
5607 }
5608
5609
5610 /* Write to descriptor DESC the NCHARS chars starting at POS of STRING.
5611 If STRING is nil, POS is the character position in the current buffer.
5612 Intersperse with them the annotations from *ANNOT
5613 which fall within the range of POS to POS + NCHARS,
5614 each at its appropriate position.
5615
5616 We modify *ANNOT by discarding elements as we use them up.
5617
5618 Return true if successful. */
5619
5620 static bool
a_write(int desc,Lisp_Object string,ptrdiff_t pos,ptrdiff_t nchars,Lisp_Object * annot,struct coding_system * coding)5621 a_write (int desc, Lisp_Object string, ptrdiff_t pos,
5622 ptrdiff_t nchars, Lisp_Object *annot,
5623 struct coding_system *coding)
5624 {
5625 Lisp_Object tem;
5626 ptrdiff_t nextpos;
5627 ptrdiff_t lastpos = pos + nchars;
5628
5629 while (NILP (*annot) || CONSP (*annot))
5630 {
5631 tem = Fcar_safe (Fcar (*annot));
5632 nextpos = pos - 1;
5633 if (FIXNUMP (tem))
5634 nextpos = XFIXNUM (tem);
5635
5636 /* If there are no more annotations in this range,
5637 output the rest of the range all at once. */
5638 if (! (nextpos >= pos && nextpos <= lastpos))
5639 return e_write (desc, string, pos, lastpos, coding);
5640
5641 /* Output buffer text up to the next annotation's position. */
5642 if (nextpos > pos)
5643 {
5644 if (!e_write (desc, string, pos, nextpos, coding))
5645 return 0;
5646 pos = nextpos;
5647 }
5648 /* Output the annotation. */
5649 tem = Fcdr (Fcar (*annot));
5650 if (STRINGP (tem))
5651 {
5652 if (!e_write (desc, tem, 0, SCHARS (tem), coding))
5653 return 0;
5654 }
5655 *annot = Fcdr (*annot);
5656 }
5657 return 1;
5658 }
5659
5660 /* Maximum number of characters that the next
5661 function encodes per one loop iteration. */
5662
5663 enum { E_WRITE_MAX = 8 * 1024 * 1024 };
5664
5665 /* Write text in the range START and END into descriptor DESC,
5666 encoding them with coding system CODING. If STRING is nil, START
5667 and END are character positions of the current buffer, else they
5668 are indexes to the string STRING. Return true if successful. */
5669
5670 static bool
e_write(int desc,Lisp_Object string,ptrdiff_t start,ptrdiff_t end,struct coding_system * coding)5671 e_write (int desc, Lisp_Object string, ptrdiff_t start, ptrdiff_t end,
5672 struct coding_system *coding)
5673 {
5674 if (STRINGP (string))
5675 {
5676 start = 0;
5677 end = SCHARS (string);
5678 }
5679
5680 /* We used to have a code for handling selective display here. But,
5681 now it is handled within encode_coding. */
5682
5683 while (start < end)
5684 {
5685 if (STRINGP (string))
5686 {
5687 coding->src_multibyte = SCHARS (string) < SBYTES (string);
5688 if (CODING_REQUIRE_ENCODING (coding))
5689 {
5690 ptrdiff_t nchars = min (end - start, E_WRITE_MAX);
5691
5692 /* Avoid creating huge Lisp string in encode_coding_object. */
5693 if (nchars == E_WRITE_MAX)
5694 coding->raw_destination = 1;
5695
5696 encode_coding_object
5697 (coding, string, start, string_char_to_byte (string, start),
5698 start + nchars, string_char_to_byte (string, start + nchars),
5699 Qt);
5700 }
5701 else
5702 {
5703 coding->dst_object = string;
5704 coding->consumed_char = SCHARS (string);
5705 coding->produced = SBYTES (string);
5706 }
5707 }
5708 else
5709 {
5710 ptrdiff_t start_byte = CHAR_TO_BYTE (start);
5711 ptrdiff_t end_byte = CHAR_TO_BYTE (end);
5712
5713 coding->src_multibyte = (end - start) < (end_byte - start_byte);
5714 if (CODING_REQUIRE_ENCODING (coding))
5715 {
5716 ptrdiff_t nchars = min (end - start, E_WRITE_MAX);
5717
5718 /* Likewise. */
5719 if (nchars == E_WRITE_MAX)
5720 coding->raw_destination = 1;
5721
5722 encode_coding_object
5723 (coding, Fcurrent_buffer (), start, start_byte,
5724 start + nchars, CHAR_TO_BYTE (start + nchars), Qt);
5725 }
5726 else
5727 {
5728 coding->dst_object = Qnil;
5729 coding->dst_pos_byte = start_byte;
5730 if (start >= GPT || end <= GPT)
5731 {
5732 coding->consumed_char = end - start;
5733 coding->produced = end_byte - start_byte;
5734 }
5735 else
5736 {
5737 coding->consumed_char = GPT - start;
5738 coding->produced = GPT_BYTE - start_byte;
5739 }
5740 }
5741 }
5742
5743 if (coding->produced > 0)
5744 {
5745 char *buf = (coding->raw_destination ? (char *) coding->destination
5746 : (STRINGP (coding->dst_object)
5747 ? SSDATA (coding->dst_object)
5748 : (char *) BYTE_POS_ADDR (coding->dst_pos_byte)));
5749 coding->produced -= emacs_write_quit (desc, buf, coding->produced);
5750
5751 if (coding->raw_destination)
5752 {
5753 /* We're responsible for freeing this, see
5754 encode_coding_object to check why. */
5755 xfree (coding->destination);
5756 coding->raw_destination = 0;
5757 }
5758 if (coding->produced)
5759 return 0;
5760 }
5761 start += coding->consumed_char;
5762 }
5763
5764 return 1;
5765 }
5766
5767 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime,
5768 Sverify_visited_file_modtime, 0, 1, 0,
5769 doc: /* Return t if last mod time of BUF's visited file matches what BUF records.
5770 This means that the file has not been changed since it was visited or saved.
5771 If BUF is omitted or nil, it defaults to the current buffer.
5772 See Info node `(elisp)Modification Time' for more details. */)
5773 (Lisp_Object buf)
5774 {
5775 struct buffer *b = decode_buffer (buf);
5776 struct stat st;
5777 Lisp_Object handler;
5778 Lisp_Object filename;
5779 struct timespec mtime;
5780
5781 if (!STRINGP (BVAR (b, filename))) return Qt;
5782 if (b->modtime.tv_nsec == UNKNOWN_MODTIME_NSECS) return Qt;
5783
5784 /* If the file name has special constructs in it,
5785 call the corresponding file name handler. */
5786 handler = Ffind_file_name_handler (BVAR (b, filename),
5787 Qverify_visited_file_modtime);
5788 if (!NILP (handler))
5789 return call2 (handler, Qverify_visited_file_modtime, buf);
5790
5791 filename = ENCODE_FILE (BVAR (b, filename));
5792
5793 mtime = (emacs_fstatat (AT_FDCWD, SSDATA (filename), &st, 0) == 0
5794 ? get_stat_mtime (&st)
5795 : time_error_value (errno));
5796 if (timespec_cmp (mtime, b->modtime) == 0
5797 && (b->modtime_size < 0
5798 || st.st_size == b->modtime_size))
5799 return Qt;
5800 return Qnil;
5801 }
5802
5803 DEFUN ("visited-file-modtime", Fvisited_file_modtime,
5804 Svisited_file_modtime, 0, 0, 0,
5805 doc: /* Return the current buffer's recorded visited file modification time.
5806 Return a Lisp timestamp (as in `current-time') if the current buffer
5807 has a recorded file modification time, 0 if it doesn't, and -1 if the
5808 visited file doesn't exist.
5809 See Info node `(elisp)Modification Time' for more details. */)
5810 (void)
5811 {
5812 int ns = current_buffer->modtime.tv_nsec;
5813 if (ns < 0)
5814 return make_fixnum (UNKNOWN_MODTIME_NSECS - ns);
5815 return make_lisp_time (current_buffer->modtime);
5816 }
5817
5818 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime,
5819 Sset_visited_file_modtime, 0, 1, 0,
5820 doc: /* Update buffer's recorded modification time from the visited file's time.
5821 Useful if the buffer was not read from the file normally
5822 or if the file itself has been changed for some known benign reason.
5823 An argument specifies the modification time value to use
5824 \(instead of that of the visited file), in the form of a time value as
5825 in `current-time' or an integer flag as returned by `visited-file-modtime'. */)
5826 (Lisp_Object time_flag)
5827 {
5828 if (!NILP (time_flag))
5829 {
5830 struct timespec mtime;
5831 if (FIXNUMP (time_flag))
5832 {
5833 int flag = check_integer_range (time_flag, -1, 0);
5834 mtime = make_timespec (0, UNKNOWN_MODTIME_NSECS - flag);
5835 }
5836 else
5837 mtime = lisp_time_argument (time_flag);
5838
5839 current_buffer->modtime = mtime;
5840 current_buffer->modtime_size = -1;
5841 }
5842 else
5843 {
5844 register Lisp_Object filename;
5845 struct stat st;
5846 Lisp_Object handler;
5847
5848 filename = Fexpand_file_name (BVAR (current_buffer, filename), Qnil);
5849
5850 /* If the file name has special constructs in it,
5851 call the corresponding file name handler. */
5852 handler = Ffind_file_name_handler (filename, Qset_visited_file_modtime);
5853 if (!NILP (handler))
5854 /* The handler can find the file name the same way we did. */
5855 return call2 (handler, Qset_visited_file_modtime, Qnil);
5856
5857 if (emacs_fstatat (AT_FDCWD, SSDATA (ENCODE_FILE (filename)), &st, 0)
5858 == 0)
5859 {
5860 current_buffer->modtime = get_stat_mtime (&st);
5861 current_buffer->modtime_size = st.st_size;
5862 }
5863 else
5864 file_attribute_errno (filename, errno);
5865 }
5866
5867 return Qnil;
5868 }
5869
5870 static Lisp_Object
auto_save_error(Lisp_Object error_val)5871 auto_save_error (Lisp_Object error_val)
5872 {
5873 auto_save_error_occurred = 1;
5874
5875 ring_bell (XFRAME (selected_frame));
5876
5877 AUTO_STRING (format, "Auto-saving %s: %s");
5878 Lisp_Object msg = CALLN (Fformat, format, BVAR (current_buffer, name),
5879 Ferror_message_string (error_val));
5880 call3 (intern ("display-warning"),
5881 intern ("auto-save"), msg, intern (":error"));
5882
5883 return Qnil;
5884 }
5885
5886 static Lisp_Object
auto_save_1(void)5887 auto_save_1 (void)
5888 {
5889 struct stat st;
5890 Lisp_Object modes;
5891
5892 auto_save_mode_bits = 0666;
5893
5894 /* Get visited file's mode to become the auto save file's mode. */
5895 if (! NILP (BVAR (current_buffer, filename)))
5896 {
5897 if (emacs_fstatat (AT_FDCWD, SSDATA (BVAR (current_buffer, filename)),
5898 &st, 0)
5899 == 0)
5900 /* But make sure we can overwrite it later! */
5901 auto_save_mode_bits = (st.st_mode | 0600) & 0777;
5902 else if (modes = Ffile_modes (BVAR (current_buffer, filename), Qnil),
5903 FIXNUMP (modes))
5904 /* Remote files don't cooperate with fstatat. */
5905 auto_save_mode_bits = (XFIXNUM (modes) | 0600) & 0777;
5906 }
5907
5908 return
5909 Fwrite_region (Qnil, Qnil, BVAR (current_buffer, auto_save_file_name), Qnil,
5910 NILP (Vauto_save_visited_file_name) ? Qlambda : Qt,
5911 Qnil, Qnil);
5912 }
5913
5914 struct auto_save_unwind
5915 {
5916 FILE *stream;
5917 bool auto_raise;
5918 };
5919
5920 static void
do_auto_save_unwind(void * arg)5921 do_auto_save_unwind (void *arg)
5922 {
5923 struct auto_save_unwind *p = arg;
5924 FILE *stream = p->stream;
5925 minibuffer_auto_raise = p->auto_raise;
5926 auto_saving = 0;
5927 if (stream != NULL)
5928 {
5929 block_input ();
5930 fclose (stream);
5931 unblock_input ();
5932 }
5933 }
5934
5935 static Lisp_Object
do_auto_save_make_dir(Lisp_Object dir)5936 do_auto_save_make_dir (Lisp_Object dir)
5937 {
5938 Lisp_Object result;
5939
5940 auto_saving_dir_umask = 077;
5941 result = call2 (Qmake_directory, dir, Qt);
5942 auto_saving_dir_umask = 0;
5943 return result;
5944 }
5945
5946 static Lisp_Object
do_auto_save_eh(Lisp_Object ignore)5947 do_auto_save_eh (Lisp_Object ignore)
5948 {
5949 auto_saving_dir_umask = 0;
5950 return Qnil;
5951 }
5952
5953 DEFUN ("do-auto-save", Fdo_auto_save, Sdo_auto_save, 0, 2, "",
5954 doc: /* Auto-save all buffers that need it.
5955 This is all buffers that have auto-saving enabled
5956 and are changed since last auto-saved.
5957 Auto-saving writes the buffer into a file
5958 so that your editing is not lost if the system crashes.
5959 This file is not the file you visited; that changes only when you save.
5960 Normally, run the normal hook `auto-save-hook' before saving.
5961
5962 A non-nil NO-MESSAGE argument means do not print any message if successful.
5963 A non-nil CURRENT-ONLY argument means save only current buffer. */)
5964 (Lisp_Object no_message, Lisp_Object current_only)
5965 {
5966 struct buffer *old = current_buffer, *b;
5967 Lisp_Object tail, buf, hook;
5968 bool auto_saved = 0;
5969 int do_handled_files;
5970 Lisp_Object oquit;
5971 FILE *stream = NULL;
5972 ptrdiff_t count = SPECPDL_INDEX ();
5973 bool orig_minibuffer_auto_raise = minibuffer_auto_raise;
5974 bool old_message_p = 0;
5975 struct auto_save_unwind auto_save_unwind;
5976
5977 intmax_t sum = INT_ADD_WRAPV (specpdl_size, 40, &sum) ? INTMAX_MAX : sum;
5978 if (max_specpdl_size < sum)
5979 max_specpdl_size = sum;
5980
5981 if (minibuf_level)
5982 no_message = Qt;
5983
5984 if (NILP (no_message))
5985 {
5986 old_message_p = push_message ();
5987 record_unwind_protect_void (pop_message_unwind);
5988 }
5989
5990 /* Ordinarily don't quit within this function,
5991 but don't make it impossible to quit (in case we get hung in I/O). */
5992 oquit = Vquit_flag;
5993 Vquit_flag = Qnil;
5994
5995 hook = intern ("auto-save-hook");
5996 safe_run_hooks (hook);
5997
5998 if (STRINGP (Vauto_save_list_file_name))
5999 {
6000 Lisp_Object listfile;
6001
6002 listfile = Fexpand_file_name (Vauto_save_list_file_name, Qnil);
6003
6004 /* Don't try to create the directory when shutting down Emacs,
6005 because creating the directory might signal an error, and
6006 that would leave Emacs in a strange state. */
6007 if (!NILP (Vrun_hooks))
6008 {
6009 Lisp_Object dir;
6010 dir = file_name_directory (listfile);
6011 if (NILP (Ffile_directory_p (dir)))
6012 internal_condition_case_1 (do_auto_save_make_dir,
6013 dir, Qt,
6014 do_auto_save_eh);
6015 }
6016
6017 stream = emacs_fopen (SSDATA (listfile), "w");
6018 }
6019
6020 auto_save_unwind.stream = stream;
6021 auto_save_unwind.auto_raise = minibuffer_auto_raise;
6022 record_unwind_protect_ptr (do_auto_save_unwind, &auto_save_unwind);
6023 minibuffer_auto_raise = 0;
6024 auto_saving = 1;
6025 auto_save_error_occurred = 0;
6026
6027 /* On first pass, save all files that don't have handlers.
6028 On second pass, save all files that do have handlers.
6029
6030 If Emacs is crashing, the handlers may tweak what is causing
6031 Emacs to crash in the first place, and it would be a shame if
6032 Emacs failed to autosave perfectly ordinary files because it
6033 couldn't handle some ange-ftp'd file. */
6034
6035 for (do_handled_files = 0; do_handled_files < 2; do_handled_files++)
FOR_EACH_LIVE_BUFFER(tail,buf)6036 FOR_EACH_LIVE_BUFFER (tail, buf)
6037 {
6038 b = XBUFFER (buf);
6039
6040 /* Record all the buffers that have auto save mode
6041 in the special file that lists them. For each of these buffers,
6042 Record visited name (if any) and auto save name. */
6043 if (STRINGP (BVAR (b, auto_save_file_name))
6044 && stream != NULL && do_handled_files == 0)
6045 {
6046 block_input ();
6047 if (!NILP (BVAR (b, filename)))
6048 fwrite (SDATA (BVAR (b, filename)), 1,
6049 SBYTES (BVAR (b, filename)), stream);
6050 putc ('\n', stream);
6051 fwrite (SDATA (BVAR (b, auto_save_file_name)), 1,
6052 SBYTES (BVAR (b, auto_save_file_name)), stream);
6053 putc ('\n', stream);
6054 unblock_input ();
6055 }
6056
6057 if (!NILP (current_only)
6058 && b != current_buffer)
6059 continue;
6060
6061 /* Don't auto-save indirect buffers.
6062 The base buffer takes care of it. */
6063 if (b->base_buffer)
6064 continue;
6065
6066 /* Check for auto save enabled
6067 and file changed since last auto save
6068 and file changed since last real save. */
6069 if (STRINGP (BVAR (b, auto_save_file_name))
6070 && BUF_SAVE_MODIFF (b) < BUF_MODIFF (b)
6071 && BUF_AUTOSAVE_MODIFF (b) < BUF_MODIFF (b)
6072 /* -1 means we've turned off autosaving for a while--see below. */
6073 && FIXNUMP (BVAR (b, save_length))
6074 && XFIXNUM (BVAR (b, save_length)) >= 0
6075 && (do_handled_files
6076 || NILP (Ffind_file_name_handler (BVAR (b, auto_save_file_name),
6077 Qwrite_region))))
6078 {
6079 struct timespec before_time = current_timespec ();
6080 struct timespec after_time;
6081
6082 /* If we had a failure, don't try again for 20 minutes. */
6083 if (b->auto_save_failure_time > 0
6084 && before_time.tv_sec - b->auto_save_failure_time < 1200)
6085 continue;
6086
6087 enum { growth_factor = 4 };
6088 verify (BUF_BYTES_MAX <= EMACS_INT_MAX / growth_factor);
6089
6090 set_buffer_internal (b);
6091 if (NILP (Vauto_save_include_big_deletions)
6092 && FIXNUMP (BVAR (b, save_length))
6093 /* A short file is likely to change a large fraction;
6094 spare the user annoying messages. */
6095 && XFIXNUM (BVAR (b, save_length)) > 5000
6096 && (growth_factor * (BUF_Z (b) - BUF_BEG (b))
6097 < (growth_factor - 1) * XFIXNUM (BVAR (b, save_length)))
6098 /* These messages are frequent and annoying for `*mail*'. */
6099 && !NILP (BVAR (b, filename))
6100 && NILP (no_message))
6101 {
6102 /* It has shrunk too much; turn off auto-saving here. */
6103 minibuffer_auto_raise = orig_minibuffer_auto_raise;
6104 message_with_string ("Buffer %s has shrunk a lot; auto save disabled in that buffer until next real save",
6105 BVAR (b, name), 1);
6106 minibuffer_auto_raise = 0;
6107 /* Turn off auto-saving until there's a real save,
6108 and prevent any more warnings. */
6109 XSETINT (BVAR (b, save_length), -1);
6110 Fsleep_for (make_fixnum (1), Qnil);
6111 continue;
6112 }
6113 if (!auto_saved && NILP (no_message))
6114 message1 ("Auto-saving...");
6115 internal_condition_case (auto_save_1, Qt, auto_save_error);
6116 auto_saved = 1;
6117 BUF_AUTOSAVE_MODIFF (b) = BUF_MODIFF (b);
6118 XSETFASTINT (BVAR (current_buffer, save_length), Z - BEG);
6119 set_buffer_internal (old);
6120
6121 after_time = current_timespec ();
6122
6123 /* If auto-save took more than 60 seconds,
6124 assume it was an NFS failure that got a timeout. */
6125 if (after_time.tv_sec - before_time.tv_sec > 60)
6126 b->auto_save_failure_time = after_time.tv_sec;
6127 }
6128 }
6129
6130 /* Prevent another auto save till enough input events come in. */
6131 record_auto_save ();
6132
6133 if (auto_saved && NILP (no_message))
6134 {
6135 if (old_message_p)
6136 {
6137 /* If we are going to restore an old message,
6138 give time to read ours. */
6139 sit_for (make_fixnum (1), 0, 0);
6140 restore_message ();
6141 }
6142 else if (!auto_save_error_occurred)
6143 /* Don't overwrite the error message if an error occurred.
6144 If we displayed a message and then restored a state
6145 with no message, leave a "done" message on the screen. */
6146 message1 ("Auto-saving...done");
6147 }
6148
6149 Vquit_flag = oquit;
6150
6151 /* This restores the message-stack status. */
6152 return unbind_to (count, Qnil);
6153 }
6154
6155 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved,
6156 Sset_buffer_auto_saved, 0, 0, 0,
6157 doc: /* Mark current buffer as auto-saved with its current text.
6158 No auto-save file will be written until the buffer changes again. */)
6159 (void)
6160 {
6161 /* FIXME: This should not be called in indirect buffers, since
6162 they're not autosaved. */
6163 BUF_AUTOSAVE_MODIFF (current_buffer) = MODIFF;
6164 XSETFASTINT (BVAR (current_buffer, save_length), Z - BEG);
6165 current_buffer->auto_save_failure_time = 0;
6166 return Qnil;
6167 }
6168
6169 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure,
6170 Sclear_buffer_auto_save_failure, 0, 0, 0,
6171 doc: /* Clear any record of a recent auto-save failure in the current buffer. */)
6172 (void)
6173 {
6174 current_buffer->auto_save_failure_time = 0;
6175 return Qnil;
6176 }
6177
6178 DEFUN ("recent-auto-save-p", Frecent_auto_save_p, Srecent_auto_save_p,
6179 0, 0, 0,
6180 doc: /* Return t if current buffer has been auto-saved recently.
6181 More precisely, if it has been auto-saved since last read from or saved
6182 in the visited file. If the buffer has no visited file,
6183 then any auto-save counts as "recent". */)
6184 (void)
6185 {
6186 /* FIXME: maybe we should return nil for indirect buffers since
6187 they're never autosaved. */
6188 return (SAVE_MODIFF < BUF_AUTOSAVE_MODIFF (current_buffer) ? Qt : Qnil);
6189 }
6190
6191 /* Reading and completing file names. */
6192
6193 DEFUN ("next-read-file-uses-dialog-p", Fnext_read_file_uses_dialog_p,
6194 Snext_read_file_uses_dialog_p, 0, 0, 0,
6195 doc: /* Return t if a call to `read-file-name' will use a dialog.
6196 The return value is only relevant for a call to `read-file-name' that happens
6197 before any other event (mouse or keypress) is handled. */)
6198 (void)
6199 {
6200 #if (defined USE_GTK || defined USE_MOTIF \
6201 || defined HAVE_NS || defined HAVE_NTGUI || defined HAVE_HAIKU)
6202 if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
6203 && use_dialog_box
6204 && use_file_dialog
6205 && window_system_available (SELECTED_FRAME ()))
6206 return Qt;
6207 #endif
6208 return Qnil;
6209 }
6210
6211
6212 DEFUN ("set-binary-mode", Fset_binary_mode, Sset_binary_mode, 2, 2, 0,
6213 doc: /* Switch STREAM to binary I/O mode or text I/O mode.
6214 STREAM can be one of the symbols `stdin', `stdout', or `stderr'.
6215 If MODE is non-nil, switch STREAM to binary mode, otherwise switch
6216 it to text mode.
6217
6218 As a side effect, this function flushes any pending STREAM's data.
6219
6220 Value is the previous value of STREAM's I/O mode, nil for text mode,
6221 non-nil for binary mode.
6222
6223 On MS-Windows and MS-DOS, binary mode is needed to read or write
6224 arbitrary binary data, and for disabling translation between CR-LF
6225 pairs and a single newline character. Examples include generation
6226 of text files with Unix-style end-of-line format using `princ' in
6227 batch mode, with standard output redirected to a file.
6228
6229 On Posix systems, this function always returns non-nil, and has no
6230 effect except for flushing STREAM's data. */)
6231 (Lisp_Object stream, Lisp_Object mode)
6232 {
6233 FILE *fp = NULL;
6234 int binmode;
6235
6236 CHECK_SYMBOL (stream);
6237 if (EQ (stream, Qstdin))
6238 fp = stdin;
6239 else if (EQ (stream, Qstdout))
6240 fp = stdout;
6241 else if (EQ (stream, Qstderr))
6242 fp = stderr;
6243 else
6244 xsignal2 (Qerror, build_string ("unsupported stream"), stream);
6245
6246 binmode = NILP (mode) ? O_TEXT : O_BINARY;
6247 if (fp != stdin)
6248 fflush (fp);
6249
6250 return (set_binary_mode (fileno (fp), binmode) == O_BINARY) ? Qt : Qnil;
6251 }
6252
6253 #ifndef DOS_NT
6254
6255 /* Yield a Lisp number equal to BLOCKSIZE * BLOCKS, with the result
6256 negated if NEGATE. */
6257 static Lisp_Object
blocks_to_bytes(uintmax_t blocksize,uintmax_t blocks,bool negate)6258 blocks_to_bytes (uintmax_t blocksize, uintmax_t blocks, bool negate)
6259 {
6260 intmax_t n;
6261 if (!INT_MULTIPLY_WRAPV (blocksize, blocks, &n))
6262 return make_int (negate ? -n : n);
6263 Lisp_Object bs = make_uint (blocksize);
6264 if (negate)
6265 bs = CALLN (Fminus, bs);
6266 return CALLN (Ftimes, bs, make_uint (blocks));
6267 }
6268
6269 DEFUN ("file-system-info", Ffile_system_info, Sfile_system_info, 1, 1, 0,
6270 doc: /* Return storage information about the file system FILENAME is on.
6271 Value is a list of numbers (TOTAL FREE AVAIL), where TOTAL is the total
6272 storage of the file system, FREE is the free storage, and AVAIL is the
6273 storage available to a non-superuser. All 3 numbers are in bytes.
6274 If the underlying system call fails, value is nil. */)
6275 (Lisp_Object filename)
6276 {
6277 filename = Fexpand_file_name (filename, Qnil);
6278
6279 /* If the file name has special constructs in it,
6280 call the corresponding file name handler. */
6281 Lisp_Object handler = Ffind_file_name_handler (filename, Qfile_system_info);
6282 if (!NILP (handler))
6283 {
6284 Lisp_Object result = call2 (handler, Qfile_system_info, filename);
6285 if (CONSP (result) || NILP (result))
6286 return result;
6287 error ("Invalid handler in `file-name-handler-alist'");
6288 }
6289
6290 struct fs_usage u;
6291 if (get_fs_usage (SSDATA (ENCODE_FILE (filename)), NULL, &u) != 0)
6292 return errno == ENOSYS ? Qnil : file_attribute_errno (filename, errno);
6293 return list3 (blocks_to_bytes (u.fsu_blocksize, u.fsu_blocks, false),
6294 blocks_to_bytes (u.fsu_blocksize, u.fsu_bfree, false),
6295 blocks_to_bytes (u.fsu_blocksize, u.fsu_bavail,
6296 u.fsu_bavail_top_bit_set));
6297 }
6298
6299 #endif /* !DOS_NT */
6300
6301 void
init_fileio(void)6302 init_fileio (void)
6303 {
6304 realmask = umask (0);
6305 umask (realmask);
6306
6307 valid_timestamp_file_system = 0;
6308
6309 /* fsync can be a significant performance hit. Often it doesn't
6310 suffice to make the file-save operation survive a crash. For
6311 batch scripts, which are typically part of larger shell commands
6312 that don't fsync other files, its effect on performance can be
6313 significant so its utility is particularly questionable.
6314 Hence, for now by default fsync is used only when interactive.
6315
6316 For more on why fsync often fails to work on today's hardware, see:
6317 Zheng M et al. Understanding the robustness of SSDs under power fault.
6318 11th USENIX Conf. on File and Storage Technologies, 2013 (FAST '13), 271-84
6319 https://www.usenix.org/system/files/conference/fast13/fast13-final80.pdf
6320
6321 For more on why fsync does not suffice even if it works properly, see:
6322 Roche X. Necessary step(s) to synchronize filename operations on disk.
6323 Austin Group Defect 672, 2013-03-19
6324 http://austingroupbugs.net/view.php?id=672 */
6325 write_region_inhibit_fsync = noninteractive;
6326 }
6327
6328 void
syms_of_fileio(void)6329 syms_of_fileio (void)
6330 {
6331 /* Property name of a file name handler,
6332 which gives a list of operations it handles. */
6333 DEFSYM (Qoperations, "operations");
6334
6335 DEFSYM (Qexpand_file_name, "expand-file-name");
6336 DEFSYM (Qsubstitute_in_file_name, "substitute-in-file-name");
6337 DEFSYM (Qdirectory_file_name, "directory-file-name");
6338 DEFSYM (Qfile_name_directory, "file-name-directory");
6339 DEFSYM (Qfile_name_nondirectory, "file-name-nondirectory");
6340 DEFSYM (Qunhandled_file_name_directory, "unhandled-file-name-directory");
6341 DEFSYM (Qfile_name_as_directory, "file-name-as-directory");
6342 DEFSYM (Qcopy_file, "copy-file");
6343 DEFSYM (Qmake_directory_internal, "make-directory-internal");
6344 DEFSYM (Qmake_directory, "make-directory");
6345 DEFSYM (Qdelete_file, "delete-file");
6346 DEFSYM (Qfile_name_case_insensitive_p, "file-name-case-insensitive-p");
6347 DEFSYM (Qrename_file, "rename-file");
6348 DEFSYM (Qadd_name_to_file, "add-name-to-file");
6349 DEFSYM (Qmake_symbolic_link, "make-symbolic-link");
6350 DEFSYM (Qfile_exists_p, "file-exists-p");
6351 DEFSYM (Qfile_executable_p, "file-executable-p");
6352 DEFSYM (Qfile_readable_p, "file-readable-p");
6353 DEFSYM (Qfile_writable_p, "file-writable-p");
6354 DEFSYM (Qfile_symlink_p, "file-symlink-p");
6355 DEFSYM (Qaccess_file, "access-file");
6356 DEFSYM (Qfile_directory_p, "file-directory-p");
6357 DEFSYM (Qfile_regular_p, "file-regular-p");
6358 DEFSYM (Qfile_accessible_directory_p, "file-accessible-directory-p");
6359 DEFSYM (Qfile_modes, "file-modes");
6360 DEFSYM (Qset_file_modes, "set-file-modes");
6361 DEFSYM (Qset_file_times, "set-file-times");
6362 DEFSYM (Qfile_selinux_context, "file-selinux-context");
6363 DEFSYM (Qset_file_selinux_context, "set-file-selinux-context");
6364 DEFSYM (Qfile_acl, "file-acl");
6365 DEFSYM (Qset_file_acl, "set-file-acl");
6366 DEFSYM (Qfile_newer_than_file_p, "file-newer-than-file-p");
6367 DEFSYM (Qinsert_file_contents, "insert-file-contents");
6368 DEFSYM (Qwrite_region, "write-region");
6369 DEFSYM (Qverify_visited_file_modtime, "verify-visited-file-modtime");
6370 DEFSYM (Qset_visited_file_modtime, "set-visited-file-modtime");
6371 DEFSYM (Qfile_system_info, "file-system-info");
6372
6373 /* The symbol bound to coding-system-for-read when
6374 insert-file-contents is called for recovering a file. This is not
6375 an actual coding system name, but just an indicator to tell
6376 insert-file-contents to use `emacs-mule' with a special flag for
6377 auto saving and recovering a file. */
6378 DEFSYM (Qauto_save_coding, "auto-save-coding");
6379
6380 DEFSYM (Qfile_name_history, "file-name-history");
6381 Fset (Qfile_name_history, Qnil);
6382
6383 DEFSYM (Qfile_error, "file-error");
6384 DEFSYM (Qfile_already_exists, "file-already-exists");
6385 DEFSYM (Qfile_date_error, "file-date-error");
6386 DEFSYM (Qfile_missing, "file-missing");
6387 DEFSYM (Qpermission_denied, "permission-denied");
6388 DEFSYM (Qfile_notify_error, "file-notify-error");
6389 DEFSYM (Qremote_file_error, "remote-file-error");
6390 DEFSYM (Qexcl, "excl");
6391
6392 DEFVAR_LISP ("file-name-coding-system", Vfile_name_coding_system,
6393 doc: /* Coding system for encoding file names.
6394 If it is nil, `default-file-name-coding-system' (which see) is used.
6395
6396 On MS-Windows, the value of this variable is largely ignored if
6397 `w32-unicode-filenames' (which see) is non-nil. Emacs on Windows
6398 behaves as if file names were encoded in `utf-8'. */);
6399 Vfile_name_coding_system = Qnil;
6400
6401 DEFVAR_LISP ("default-file-name-coding-system",
6402 Vdefault_file_name_coding_system,
6403 doc: /* Default coding system for encoding file names.
6404 This variable is used only when `file-name-coding-system' is nil.
6405
6406 This variable is set/changed by the command `set-language-environment'.
6407 User should not set this variable manually,
6408 instead use `file-name-coding-system' to get a constant encoding
6409 of file names regardless of the current language environment.
6410
6411 On MS-Windows, the value of this variable is largely ignored if
6412 `w32-unicode-filenames' (which see) is non-nil. Emacs on Windows
6413 behaves as if file names were encoded in `utf-8'. */);
6414 Vdefault_file_name_coding_system = Qnil;
6415
6416 /* Lisp functions for translating file formats. */
6417 DEFSYM (Qformat_decode, "format-decode");
6418 DEFSYM (Qformat_annotate_function, "format-annotate-function");
6419
6420 /* Lisp function for setting buffer-file-coding-system and the
6421 multibyteness of the current buffer after inserting a file. */
6422 DEFSYM (Qafter_insert_file_set_coding, "after-insert-file-set-coding");
6423
6424 DEFSYM (Qcar_less_than_car, "car-less-than-car");
6425
6426 Fput (Qfile_error, Qerror_conditions,
6427 Fpurecopy (list2 (Qfile_error, Qerror)));
6428 Fput (Qfile_error, Qerror_message,
6429 build_pure_c_string ("File error"));
6430
6431 Fput (Qfile_already_exists, Qerror_conditions,
6432 Fpurecopy (list3 (Qfile_already_exists, Qfile_error, Qerror)));
6433 Fput (Qfile_already_exists, Qerror_message,
6434 build_pure_c_string ("File already exists"));
6435
6436 Fput (Qfile_date_error, Qerror_conditions,
6437 Fpurecopy (list3 (Qfile_date_error, Qfile_error, Qerror)));
6438 Fput (Qfile_date_error, Qerror_message,
6439 build_pure_c_string ("Cannot set file date"));
6440
6441 Fput (Qfile_missing, Qerror_conditions,
6442 Fpurecopy (list3 (Qfile_missing, Qfile_error, Qerror)));
6443 Fput (Qfile_missing, Qerror_message,
6444 build_pure_c_string ("File is missing"));
6445
6446 Fput (Qpermission_denied, Qerror_conditions,
6447 Fpurecopy (list3 (Qpermission_denied, Qfile_error, Qerror)));
6448 Fput (Qpermission_denied, Qerror_message,
6449 build_pure_c_string ("Cannot access file or directory"));
6450
6451 Fput (Qfile_notify_error, Qerror_conditions,
6452 Fpurecopy (list3 (Qfile_notify_error, Qfile_error, Qerror)));
6453 Fput (Qfile_notify_error, Qerror_message,
6454 build_pure_c_string ("File notification error"));
6455
6456 Fput (Qremote_file_error, Qerror_conditions,
6457 Fpurecopy (list3 (Qremote_file_error, Qfile_error, Qerror)));
6458 Fput (Qremote_file_error, Qerror_message,
6459 build_pure_c_string ("Remote file error"));
6460
6461 DEFVAR_LISP ("file-name-handler-alist", Vfile_name_handler_alist,
6462 doc: /* Alist of elements (REGEXP . HANDLER) for file names handled specially.
6463 If a file name matches REGEXP, all I/O on that file is done by calling
6464 HANDLER. If a file name matches more than one handler, the handler
6465 whose match starts last in the file name gets precedence. The
6466 function `find-file-name-handler' checks this list for a handler for
6467 its argument.
6468
6469 HANDLER should be a function. The first argument given to it is the
6470 name of the I/O primitive to be handled; the remaining arguments are
6471 the arguments that were passed to that primitive. For example, if you
6472 do (file-exists-p FILENAME) and FILENAME is handled by HANDLER, then
6473 HANDLER is called like this:
6474
6475 (funcall HANDLER \\='file-exists-p FILENAME)
6476
6477 Note that HANDLER must be able to handle all I/O primitives; if it has
6478 nothing special to do for a primitive, it should reinvoke the
6479 primitive to handle the operation \"the usual way\".
6480 See Info node `(elisp)Magic File Names' for more details. */);
6481 Vfile_name_handler_alist = Qnil;
6482
6483 DEFVAR_LISP ("set-auto-coding-function",
6484 Vset_auto_coding_function,
6485 doc: /* If non-nil, a function to call to decide a coding system of file.
6486 Two arguments are passed to this function: the file name
6487 and the length of a file contents following the point.
6488 This function should return a coding system to decode the file contents.
6489 It should check the file name against `auto-coding-alist'.
6490 If no coding system is decided, it should check a coding system
6491 specified in the heading lines with the format:
6492 -*- ... coding: CODING-SYSTEM; ... -*-
6493 or local variable spec of the tailing lines with `coding:' tag. */);
6494 Vset_auto_coding_function = Qnil;
6495
6496 DEFVAR_LISP ("after-insert-file-functions", Vafter_insert_file_functions,
6497 doc: /* A list of functions to be called at the end of `insert-file-contents'.
6498 Each is passed one argument, the number of characters inserted,
6499 with point at the start of the inserted text. Each function
6500 should leave point the same, and return the new character count.
6501 If `insert-file-contents' is intercepted by a handler from
6502 `file-name-handler-alist', that handler is responsible for calling the
6503 functions in `after-insert-file-functions' if appropriate. */);
6504 Vafter_insert_file_functions = Qnil;
6505
6506 DEFVAR_LISP ("write-region-annotate-functions", Vwrite_region_annotate_functions,
6507 doc: /* A list of functions to be called at the start of `write-region'.
6508 Each is passed two arguments, START and END as for `write-region'.
6509 These are usually two numbers but not always; see the documentation
6510 for `write-region'. The function should return a list of pairs
6511 of the form (POSITION . STRING), consisting of strings to be effectively
6512 inserted at the specified positions of the file being written (1 means to
6513 insert before the first byte written). The POSITIONs must be sorted into
6514 increasing order.
6515
6516 If there are several annotation functions, the lists returned by these
6517 functions are merged destructively. As each annotation function runs,
6518 the variable `write-region-annotations-so-far' contains a list of all
6519 annotations returned by previous annotation functions.
6520
6521 An annotation function can return with a different buffer current.
6522 Doing so removes the annotations returned by previous functions, and
6523 resets START and END to `point-min' and `point-max' of the new buffer.
6524
6525 After `write-region' completes, Emacs calls the function stored in
6526 `write-region-post-annotation-function', once for each buffer that was
6527 current when building the annotations (i.e., at least once), with that
6528 buffer current. */);
6529 Vwrite_region_annotate_functions = Qnil;
6530 DEFSYM (Qwrite_region_annotate_functions, "write-region-annotate-functions");
6531
6532 DEFVAR_LISP ("write-region-post-annotation-function",
6533 Vwrite_region_post_annotation_function,
6534 doc: /* Function to call after `write-region' completes.
6535 The function is called with no arguments. If one or more of the
6536 annotation functions in `write-region-annotate-functions' changed the
6537 current buffer, the function stored in this variable is called for
6538 each of those additional buffers as well, in addition to the original
6539 buffer. The relevant buffer is current during each function call. */);
6540 Vwrite_region_post_annotation_function = Qnil;
6541 staticpro (&Vwrite_region_annotation_buffers);
6542
6543 DEFVAR_LISP ("write-region-annotations-so-far",
6544 Vwrite_region_annotations_so_far,
6545 doc: /* When an annotation function is called, this holds the previous annotations.
6546 These are the annotations made by other annotation functions
6547 that were already called. See also `write-region-annotate-functions'. */);
6548 Vwrite_region_annotations_so_far = Qnil;
6549
6550 DEFVAR_LISP ("inhibit-file-name-handlers", Vinhibit_file_name_handlers,
6551 doc: /* A list of file name handlers that temporarily should not be used.
6552 This applies only to the operation `inhibit-file-name-operation'. */);
6553 Vinhibit_file_name_handlers = Qnil;
6554
6555 DEFVAR_LISP ("inhibit-file-name-operation", Vinhibit_file_name_operation,
6556 doc: /* The operation for which `inhibit-file-name-handlers' is applicable. */);
6557 Vinhibit_file_name_operation = Qnil;
6558
6559 DEFVAR_LISP ("auto-save-list-file-name", Vauto_save_list_file_name,
6560 doc: /* File name in which to write a list of all auto save file names.
6561 This variable is initialized automatically from `auto-save-list-file-prefix'
6562 shortly after Emacs reads your init file, if you have not yet given it
6563 a non-nil value. */);
6564 Vauto_save_list_file_name = Qnil;
6565
6566 DEFVAR_LISP ("auto-save-visited-file-name", Vauto_save_visited_file_name,
6567 doc: /* Non-nil says auto-save a buffer in the file it is visiting, when practical.
6568 Normally auto-save files are written under other names. */);
6569 Vauto_save_visited_file_name = Qnil;
6570
6571 DEFVAR_LISP ("auto-save-include-big-deletions", Vauto_save_include_big_deletions,
6572 doc: /* If non-nil, auto-save even if a large part of the text is deleted.
6573 If nil, deleting a substantial portion of the text disables auto-save
6574 in the buffer; this is the default behavior, because the auto-save
6575 file is usually more useful if it contains the deleted text. */);
6576 Vauto_save_include_big_deletions = Qnil;
6577
6578 DEFVAR_BOOL ("write-region-inhibit-fsync", write_region_inhibit_fsync,
6579 doc: /* Non-nil means don't call fsync in `write-region'.
6580 This variable affects calls to `write-region' as well as save commands.
6581 Setting this to nil may avoid data loss if the system loses power or
6582 the operating system crashes. By default, it is non-nil in batch mode. */);
6583 write_region_inhibit_fsync = 0; /* See also `init_fileio' above. */
6584
6585 DEFVAR_BOOL ("delete-by-moving-to-trash", delete_by_moving_to_trash,
6586 doc: /* Specifies whether to use the system's trash can.
6587 When non-nil, certain file deletion commands use the function
6588 `move-file-to-trash' instead of deleting files outright.
6589 This includes interactive calls to `delete-file' and
6590 `delete-directory' and the Dired deletion commands. */);
6591 delete_by_moving_to_trash = 0;
6592 DEFSYM (Qdelete_by_moving_to_trash, "delete-by-moving-to-trash");
6593
6594 /* Lisp function for moving files to trash. */
6595 DEFSYM (Qmove_file_to_trash, "move-file-to-trash");
6596
6597 /* Lisp function for recursively copying directories. */
6598 DEFSYM (Qcopy_directory, "copy-directory");
6599
6600 /* Lisp function for recursively deleting directories. */
6601 DEFSYM (Qdelete_directory, "delete-directory");
6602
6603 DEFSYM (Qsubstitute_env_in_file_name, "substitute-env-in-file-name");
6604 DEFSYM (Qget_buffer_window_list, "get-buffer-window-list");
6605
6606 DEFSYM (Qstdin, "stdin");
6607 DEFSYM (Qstdout, "stdout");
6608 DEFSYM (Qstderr, "stderr");
6609
6610 defsubr (&Sfind_file_name_handler);
6611 defsubr (&Sfile_name_directory);
6612 defsubr (&Sfile_name_nondirectory);
6613 defsubr (&Sunhandled_file_name_directory);
6614 defsubr (&Sfile_name_as_directory);
6615 defsubr (&Sdirectory_name_p);
6616 defsubr (&Sdirectory_file_name);
6617 defsubr (&Smake_temp_file_internal);
6618 defsubr (&Smake_temp_name);
6619 defsubr (&Sfile_name_concat);
6620 defsubr (&Sexpand_file_name);
6621 defsubr (&Ssubstitute_in_file_name);
6622 defsubr (&Scopy_file);
6623 defsubr (&Smake_directory_internal);
6624 defsubr (&Sdelete_directory_internal);
6625 defsubr (&Sdelete_file);
6626 defsubr (&Sfile_name_case_insensitive_p);
6627 defsubr (&Srename_file);
6628 defsubr (&Sadd_name_to_file);
6629 defsubr (&Smake_symbolic_link);
6630 defsubr (&Sfile_name_absolute_p);
6631 defsubr (&Sfile_exists_p);
6632 defsubr (&Sfile_executable_p);
6633 defsubr (&Sfile_readable_p);
6634 defsubr (&Sfile_writable_p);
6635 defsubr (&Saccess_file);
6636 defsubr (&Sfile_symlink_p);
6637 defsubr (&Sfile_directory_p);
6638 defsubr (&Sfile_accessible_directory_p);
6639 defsubr (&Sfile_regular_p);
6640 defsubr (&Sfile_modes);
6641 defsubr (&Sset_file_modes);
6642 defsubr (&Sset_file_times);
6643 defsubr (&Sfile_selinux_context);
6644 defsubr (&Sfile_acl);
6645 defsubr (&Sset_file_acl);
6646 defsubr (&Sset_file_selinux_context);
6647 defsubr (&Sset_default_file_modes);
6648 defsubr (&Sdefault_file_modes);
6649 defsubr (&Sfile_newer_than_file_p);
6650 defsubr (&Sinsert_file_contents);
6651 defsubr (&Swrite_region);
6652 defsubr (&Scar_less_than_car);
6653 defsubr (&Sverify_visited_file_modtime);
6654 defsubr (&Svisited_file_modtime);
6655 defsubr (&Sset_visited_file_modtime);
6656 defsubr (&Sdo_auto_save);
6657 defsubr (&Sset_buffer_auto_saved);
6658 defsubr (&Sclear_buffer_auto_save_failure);
6659 defsubr (&Srecent_auto_save_p);
6660
6661 defsubr (&Snext_read_file_uses_dialog_p);
6662
6663 defsubr (&Sset_binary_mode);
6664
6665 #ifndef DOS_NT
6666 defsubr (&Sfile_system_info);
6667 #endif
6668
6669 #ifdef HAVE_SYNC
6670 defsubr (&Sunix_sync);
6671 #endif
6672 }
6673