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