1 /* File IO for GNU Emacs.
3 Copyright (C) 1985, 1986, 1987, 1988, 1993, 1994, 1995, 1996, 1997,
4 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
5 2009, 2010, 2011 Free Software Foundation, Inc.
7 This file is part of GNU Emacs.
9 GNU Emacs is free software: you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation, either version 3 of the License, or
12 (at your option) any later version.
14 GNU Emacs is distributed in the hope that it will be useful,
15 but WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 GNU General Public License for more details.
19 You should have received a copy of the GNU General Public License
20 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
26 #include <sys/types.h>
31 #if !defined (S_ISLNK) && defined (S_IFLNK)
32 # define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK)
35 #if !defined (S_ISFIFO) && defined (S_IFIFO)
36 # define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO)
39 #if !defined (S_ISREG) && defined (S_IFREG)
40 # define S_ISREG(m) (((m) & S_IFMT) == S_IFREG)
50 #ifdef HAVE_LIBSELINUX
51 #include <selinux/selinux.h>
52 #include <selinux/context.h>
56 #include "intervals.h"
58 #include "character.h"
61 #include "blockinput.h"
63 #include "dispextern.h"
69 #endif /* not WINDOWSNT */
73 #include <sys/param.h>
78 /* On Windows, drive letters must be alphabetic - on DOS, the Netware
79 redirector allows the six letters between 'Z' and 'a' as well. */
81 #define IS_DRIVE(x) ((x) >= 'A' && (x) <= 'z')
84 #define IS_DRIVE(x) isalpha (x)
86 /* Need to lower-case the drive letter, or else expanded
87 filenames will sometimes compare inequal, because
88 `expand-file-name' doesn't always down-case the drive letter. */
89 #define DRIVE_LETTER(x) (tolower (x))
104 #ifndef FILE_SYSTEM_CASE
105 #define FILE_SYSTEM_CASE(filename) (filename)
108 /* Nonzero during writing of auto-save files */
111 /* Set by auto_save_1 to mode of original file so Fwrite_region will create
112 a new file with the same mode as the original */
113 int auto_save_mode_bits
;
115 /* Set by auto_save_1 if an error occurred during the last auto-save. */
116 int auto_save_error_occurred
;
118 /* The symbol bound to coding-system-for-read when
119 insert-file-contents is called for recovering a file. This is not
120 an actual coding system name, but just an indicator to tell
121 insert-file-contents to use `emacs-mule' with a special flag for
122 auto saving and recovering a file. */
123 Lisp_Object Qauto_save_coding
;
125 /* Coding system for file names, or nil if none. */
126 Lisp_Object Vfile_name_coding_system
;
128 /* Coding system for file names used only when
129 Vfile_name_coding_system is nil. */
130 Lisp_Object Vdefault_file_name_coding_system
;
132 /* Alist of elements (REGEXP . HANDLER) for file names
133 whose I/O is done with a special handler. */
134 Lisp_Object Vfile_name_handler_alist
;
136 /* Property name of a file name handler,
137 which gives a list of operations it handles.. */
138 Lisp_Object Qoperations
;
140 /* Lisp functions for translating file formats */
141 Lisp_Object Qformat_decode
, Qformat_annotate_function
;
143 /* Function to be called to decide a coding system of a reading file. */
144 Lisp_Object Vset_auto_coding_function
;
146 /* Functions to be called to process text properties in inserted file. */
147 Lisp_Object Vafter_insert_file_functions
;
149 /* Lisp function for setting buffer-file-coding-system and the
150 multibyteness of the current buffer after inserting a file. */
151 Lisp_Object Qafter_insert_file_set_coding
;
153 /* Functions to be called to create text property annotations for file. */
154 Lisp_Object Vwrite_region_annotate_functions
;
155 Lisp_Object Qwrite_region_annotate_functions
;
156 Lisp_Object Vwrite_region_post_annotation_function
;
158 /* During build_annotations, each time an annotation function is called,
159 this holds the annotations made by the previous functions. */
160 Lisp_Object Vwrite_region_annotations_so_far
;
162 /* Each time an annotation function changes the buffer, the new buffer
164 Lisp_Object Vwrite_region_annotation_buffers
;
166 /* File name in which we write a list of all our auto save files. */
167 Lisp_Object Vauto_save_list_file_name
;
169 /* Whether or not files are auto-saved into themselves. */
170 Lisp_Object Vauto_save_visited_file_name
;
172 /* Whether or not to continue auto-saving after a large deletion. */
173 Lisp_Object Vauto_save_include_big_deletions
;
176 /* Nonzero means skip the call to fsync in Fwrite-region. */
177 int write_region_inhibit_fsync
;
180 /* Non-zero means call move-file-to-trash in Fdelete_file or
181 Fdelete_directory_internal. */
182 int delete_by_moving_to_trash
;
184 Lisp_Object Qdelete_by_moving_to_trash
;
186 /* Lisp function for moving files to trash. */
187 Lisp_Object Qmove_file_to_trash
;
189 /* Lisp function for recursively copying directories. */
190 Lisp_Object Qcopy_directory
;
192 /* Lisp function for recursively deleting directories. */
193 Lisp_Object Qdelete_directory
;
196 extern Lisp_Object Vw32_get_true_file_attributes
;
199 /* These variables describe handlers that have "already" had a chance
200 to handle the current operation.
202 Vinhibit_file_name_handlers is a list of file name handlers.
203 Vinhibit_file_name_operation is the operation being handled.
204 If we try to handle that operation, we ignore those handlers. */
206 static Lisp_Object Vinhibit_file_name_handlers
;
207 static Lisp_Object Vinhibit_file_name_operation
;
209 Lisp_Object Qfile_error
, Qfile_already_exists
, Qfile_date_error
;
211 Lisp_Object Qfile_name_history
;
213 Lisp_Object Qcar_less_than_car
;
215 static int a_write (int, Lisp_Object
, int, int,
216 Lisp_Object
*, struct coding_system
*);
217 static int e_write (int, Lisp_Object
, int, int, struct coding_system
*);
221 report_file_error (const char *string
, Lisp_Object data
)
223 Lisp_Object errstring
;
227 synchronize_system_messages_locale ();
228 str
= strerror (errorno
);
229 errstring
= code_convert_string_norecord (make_unibyte_string (str
,
231 Vlocale_coding_system
, 0);
237 xsignal (Qfile_already_exists
, Fcons (errstring
, data
));
240 /* System error messages are capitalized. Downcase the initial
241 unless it is followed by a slash. (The slash case caters to
242 error messages that begin with "I/O" or, in German, "E/A".) */
243 if (STRING_MULTIBYTE (errstring
)
244 && ! EQ (Faref (errstring
, make_number (1)), make_number ('/')))
248 str
= (char *) SDATA (errstring
);
249 c
= STRING_CHAR (str
);
250 Faset (errstring
, make_number (0), make_number (DOWNCASE (c
)));
253 xsignal (Qfile_error
,
254 Fcons (build_string (string
), Fcons (errstring
, data
)));
259 close_file_unwind (Lisp_Object fd
)
261 emacs_close (XFASTINT (fd
));
265 /* Restore point, having saved it as a marker. */
268 restore_point_unwind (Lisp_Object location
)
270 Fgoto_char (location
);
271 Fset_marker (location
, Qnil
, Qnil
);
276 Lisp_Object Qexpand_file_name
;
277 Lisp_Object Qsubstitute_in_file_name
;
278 Lisp_Object Qdirectory_file_name
;
279 Lisp_Object Qfile_name_directory
;
280 Lisp_Object Qfile_name_nondirectory
;
281 Lisp_Object Qunhandled_file_name_directory
;
282 Lisp_Object Qfile_name_as_directory
;
283 Lisp_Object Qcopy_file
;
284 Lisp_Object Qmake_directory_internal
;
285 Lisp_Object Qmake_directory
;
286 Lisp_Object Qdelete_directory_internal
;
287 Lisp_Object Qdelete_file
;
288 Lisp_Object Qrename_file
;
289 Lisp_Object Qadd_name_to_file
;
290 Lisp_Object Qmake_symbolic_link
;
291 Lisp_Object Qfile_exists_p
;
292 Lisp_Object Qfile_executable_p
;
293 Lisp_Object Qfile_readable_p
;
294 Lisp_Object Qfile_writable_p
;
295 Lisp_Object Qfile_symlink_p
;
296 Lisp_Object Qaccess_file
;
297 Lisp_Object Qfile_directory_p
;
298 Lisp_Object Qfile_regular_p
;
299 Lisp_Object Qfile_accessible_directory_p
;
300 Lisp_Object Qfile_modes
;
301 Lisp_Object Qset_file_modes
;
302 Lisp_Object Qset_file_times
;
303 Lisp_Object Qfile_selinux_context
;
304 Lisp_Object Qset_file_selinux_context
;
305 Lisp_Object Qfile_newer_than_file_p
;
306 Lisp_Object Qinsert_file_contents
;
307 Lisp_Object Qwrite_region
;
308 Lisp_Object Qverify_visited_file_modtime
;
309 Lisp_Object Qset_visited_file_modtime
;
311 DEFUN ("find-file-name-handler", Ffind_file_name_handler
, Sfind_file_name_handler
, 2, 2, 0,
312 doc
: /* Return FILENAME's handler function for OPERATION, if it has one.
313 Otherwise, return nil.
314 A file name is handled if one of the regular expressions in
315 `file-name-handler-alist' matches it.
317 If OPERATION equals `inhibit-file-name-operation', then we ignore
318 any handlers that are members of `inhibit-file-name-handlers',
319 but we still do run any other handlers. This lets handlers
320 use the standard functions without calling themselves recursively. */)
321 (Lisp_Object filename
, Lisp_Object operation
)
323 /* This function must not munge the match data. */
324 Lisp_Object chain
, inhibited_handlers
, result
;
328 CHECK_STRING (filename
);
330 if (EQ (operation
, Vinhibit_file_name_operation
))
331 inhibited_handlers
= Vinhibit_file_name_handlers
;
333 inhibited_handlers
= Qnil
;
335 for (chain
= Vfile_name_handler_alist
; CONSP (chain
);
336 chain
= XCDR (chain
))
342 Lisp_Object string
= XCAR (elt
);
344 Lisp_Object handler
= XCDR (elt
);
345 Lisp_Object operations
= Qnil
;
347 if (SYMBOLP (handler
))
348 operations
= Fget (handler
, Qoperations
);
351 && (match_pos
= fast_string_match (string
, filename
)) > pos
352 && (NILP (operations
) || ! NILP (Fmemq (operation
, operations
))))
356 handler
= XCDR (elt
);
357 tem
= Fmemq (handler
, inhibited_handlers
);
371 DEFUN ("file-name-directory", Ffile_name_directory
, Sfile_name_directory
,
373 doc
: /* Return the directory component in file name FILENAME.
374 Return nil if FILENAME does not include a directory.
375 Otherwise return a directory name.
376 Given a Unix syntax file name, returns a string ending in slash. */)
377 (Lisp_Object filename
)
380 register const unsigned char *beg
;
382 register unsigned char *beg
;
384 register const unsigned char *p
;
387 CHECK_STRING (filename
);
389 /* If the file name has special constructs in it,
390 call the corresponding file handler. */
391 handler
= Ffind_file_name_handler (filename
, Qfile_name_directory
);
393 return call2 (handler
, Qfile_name_directory
, filename
);
395 filename
= FILE_SYSTEM_CASE (filename
);
397 beg
= (unsigned char *) alloca (SBYTES (filename
) + 1);
398 memcpy (beg
, SDATA (filename
), SBYTES (filename
) + 1);
400 beg
= SDATA (filename
);
402 p
= beg
+ SBYTES (filename
);
404 while (p
!= beg
&& !IS_DIRECTORY_SEP (p
[-1])
406 /* only recognise drive specifier at the beginning */
408 /* handle the "/:d:foo" and "/:foo" cases correctly */
409 && ((p
== beg
+ 2 && !IS_DIRECTORY_SEP (*beg
))
410 || (p
== beg
+ 4 && IS_DIRECTORY_SEP (*beg
))))
417 /* Expansion of "c:" to drive and default directory. */
420 /* MAXPATHLEN+1 is guaranteed to be enough space for getdefdir. */
421 unsigned char *res
= alloca (MAXPATHLEN
+ 1);
422 unsigned char *r
= res
;
424 if (p
== beg
+ 4 && IS_DIRECTORY_SEP (*beg
) && beg
[1] == ':')
426 strncpy (res
, beg
, 2);
431 if (getdefdir (toupper (*beg
) - 'A' + 1, r
))
433 if (!IS_DIRECTORY_SEP (res
[strlen (res
) - 1]))
436 p
= beg
+ strlen (beg
);
439 dostounix_filename (beg
);
442 return make_specified_string (beg
, -1, p
- beg
, STRING_MULTIBYTE (filename
));
445 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory
,
446 Sfile_name_nondirectory
, 1, 1, 0,
447 doc
: /* Return file name FILENAME sans its directory.
448 For example, in a Unix-syntax file name,
449 this is everything after the last slash,
450 or the entire name if it contains no slash. */)
451 (Lisp_Object filename
)
453 register const unsigned char *beg
, *p
, *end
;
456 CHECK_STRING (filename
);
458 /* If the file name has special constructs in it,
459 call the corresponding file handler. */
460 handler
= Ffind_file_name_handler (filename
, Qfile_name_nondirectory
);
462 return call2 (handler
, Qfile_name_nondirectory
, filename
);
464 beg
= SDATA (filename
);
465 end
= p
= beg
+ SBYTES (filename
);
467 while (p
!= beg
&& !IS_DIRECTORY_SEP (p
[-1])
469 /* only recognise drive specifier at beginning */
471 /* handle the "/:d:foo" case correctly */
472 && (p
== beg
+ 2 || (p
== beg
+ 4 && IS_DIRECTORY_SEP (*beg
))))
477 return make_specified_string (p
, -1, end
- p
, STRING_MULTIBYTE (filename
));
480 DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory
,
481 Sunhandled_file_name_directory
, 1, 1, 0,
482 doc
: /* Return a directly usable directory name somehow associated with FILENAME.
483 A `directly usable' directory name is one that may be used without the
484 intervention of any file handler.
485 If FILENAME is a directly usable file itself, return
486 \(file-name-directory FILENAME).
487 If FILENAME refers to a file which is not accessible from a local process,
488 then this should return nil.
489 The `call-process' and `start-process' functions use this function to
490 get a current directory to run processes in. */)
491 (Lisp_Object filename
)
495 /* If the file name has special constructs in it,
496 call the corresponding file handler. */
497 handler
= Ffind_file_name_handler (filename
, Qunhandled_file_name_directory
);
499 return call2 (handler
, Qunhandled_file_name_directory
, filename
);
501 return Ffile_name_directory (filename
);
506 file_name_as_directory (char *out
, char *in
)
508 int size
= strlen (in
) - 1;
520 /* For Unix syntax, Append a slash if necessary */
521 if (!IS_DIRECTORY_SEP (out
[size
]))
523 out
[size
+ 1] = DIRECTORY_SEP
;
524 out
[size
+ 2] = '\0';
527 dostounix_filename (out
);
532 DEFUN ("file-name-as-directory", Ffile_name_as_directory
,
533 Sfile_name_as_directory
, 1, 1, 0,
534 doc
: /* Return a string representing the file name FILE interpreted as a directory.
535 This operation exists because a directory is also a file, but its name as
536 a directory is different from its name as a file.
537 The result can be used as the value of `default-directory'
538 or passed as second argument to `expand-file-name'.
539 For a Unix-syntax file name, just appends a slash. */)
549 /* If the file name has special constructs in it,
550 call the corresponding file handler. */
551 handler
= Ffind_file_name_handler (file
, Qfile_name_as_directory
);
553 return call2 (handler
, Qfile_name_as_directory
, file
);
555 buf
= (char *) alloca (SBYTES (file
) + 10);
556 file_name_as_directory (buf
, SDATA (file
));
557 return make_specified_string (buf
, -1, strlen (buf
),
558 STRING_MULTIBYTE (file
));
562 * Convert from directory name to filename.
563 * On UNIX, it's simple: just make sure there isn't a terminating /
565 * Value is nonzero if the string output is different from the input.
569 directory_file_name (char *src
, char *dst
)
575 /* Process as Unix format: just remove any final slash.
576 But leave "/" unchanged; do not change it to "". */
579 && IS_DIRECTORY_SEP (dst
[slen
- 1])
581 && !IS_ANY_SEP (dst
[slen
- 2])
586 dostounix_filename (dst
);
591 DEFUN ("directory-file-name", Fdirectory_file_name
, Sdirectory_file_name
,
593 doc
: /* Returns the file name of the directory named DIRECTORY.
594 This is the name of the file that holds the data for the directory DIRECTORY.
595 This operation exists because a directory is also a file, but its name as
596 a directory is different from its name as a file.
597 In Unix-syntax, this function just removes the final slash. */)
598 (Lisp_Object directory
)
603 CHECK_STRING (directory
);
605 if (NILP (directory
))
608 /* If the file name has special constructs in it,
609 call the corresponding file handler. */
610 handler
= Ffind_file_name_handler (directory
, Qdirectory_file_name
);
612 return call2 (handler
, Qdirectory_file_name
, directory
);
614 buf
= (char *) alloca (SBYTES (directory
) + 20);
615 directory_file_name (SDATA (directory
), buf
);
616 return make_specified_string (buf
, -1, strlen (buf
),
617 STRING_MULTIBYTE (directory
));
620 static const char make_temp_name_tbl
[64] =
622 'A','B','C','D','E','F','G','H',
623 'I','J','K','L','M','N','O','P',
624 'Q','R','S','T','U','V','W','X',
625 'Y','Z','a','b','c','d','e','f',
626 'g','h','i','j','k','l','m','n',
627 'o','p','q','r','s','t','u','v',
628 'w','x','y','z','0','1','2','3',
629 '4','5','6','7','8','9','-','_'
632 static unsigned make_temp_name_count
, make_temp_name_count_initialized_p
;
634 /* Value is a temporary file name starting with PREFIX, a string.
636 The Emacs process number forms part of the result, so there is
637 no danger of generating a name being used by another process.
638 In addition, this function makes an attempt to choose a name
639 which has no existing file. To make this work, PREFIX should be
640 an absolute file name.
642 BASE64_P non-zero means add the pid as 3 characters in base64
643 encoding. In this case, 6 characters will be added to PREFIX to
644 form the file name. Otherwise, if Emacs is running on a system
645 with long file names, add the pid as a decimal number.
647 This function signals an error if no unique file name could be
651 make_temp_name (Lisp_Object prefix
, int base64_p
)
656 unsigned char *p
, *data
;
660 CHECK_STRING (prefix
);
662 /* VAL is created by adding 6 characters to PREFIX. The first
663 three are the PID of this process, in base 64, and the second
664 three are incremented if the file already exists. This ensures
665 262144 unique file names per PID per PREFIX. */
667 pid
= (int) getpid ();
671 pidbuf
[0] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
672 pidbuf
[1] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
673 pidbuf
[2] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
678 #ifdef HAVE_LONG_FILE_NAMES
679 sprintf (pidbuf
, "%d", pid
);
680 pidlen
= strlen (pidbuf
);
682 pidbuf
[0] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
683 pidbuf
[1] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
684 pidbuf
[2] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
689 len
= SBYTES (prefix
); clen
= SCHARS (prefix
);
690 val
= make_uninit_multibyte_string (clen
+ 3 + pidlen
, len
+ 3 + pidlen
);
691 if (!STRING_MULTIBYTE (prefix
))
692 STRING_SET_UNIBYTE (val
);
694 memcpy (data
, SDATA (prefix
), len
);
697 memcpy (p
, pidbuf
, pidlen
);
700 /* Here we try to minimize useless stat'ing when this function is
701 invoked many times successively with the same PREFIX. We achieve
702 this by initializing count to a random value, and incrementing it
705 We don't want make-temp-name to be called while dumping,
706 because then make_temp_name_count_initialized_p would get set
707 and then make_temp_name_count would not be set when Emacs starts. */
709 if (!make_temp_name_count_initialized_p
)
711 make_temp_name_count
= (unsigned) time (NULL
);
712 make_temp_name_count_initialized_p
= 1;
718 unsigned num
= make_temp_name_count
;
720 p
[0] = make_temp_name_tbl
[num
& 63], num
>>= 6;
721 p
[1] = make_temp_name_tbl
[num
& 63], num
>>= 6;
722 p
[2] = make_temp_name_tbl
[num
& 63], num
>>= 6;
724 /* Poor man's congruential RN generator. Replace with
725 ++make_temp_name_count for debugging. */
726 make_temp_name_count
+= 25229;
727 make_temp_name_count
%= 225307;
729 if (stat (data
, &ignored
) < 0)
731 /* We want to return only if errno is ENOENT. */
735 /* The error here is dubious, but there is little else we
736 can do. The alternatives are to return nil, which is
737 as bad as (and in many cases worse than) throwing the
738 error, or to ignore the error, which will likely result
739 in looping through 225307 stat's, which is not only
740 dog-slow, but also useless since it will fallback to
741 the errow below, anyway. */
742 report_file_error ("Cannot create temporary name for prefix",
743 Fcons (prefix
, Qnil
));
748 error ("Cannot create temporary name for prefix `%s'",
754 DEFUN ("make-temp-name", Fmake_temp_name
, Smake_temp_name
, 1, 1, 0,
755 doc
: /* Generate temporary file name (string) starting with PREFIX (a string).
756 The Emacs process number forms part of the result,
757 so there is no danger of generating a name being used by another process.
759 In addition, this function makes an attempt to choose a name
760 which has no existing file. To make this work,
761 PREFIX should be an absolute file name.
763 There is a race condition between calling `make-temp-name' and creating the
764 file which opens all kinds of security holes. For that reason, you should
765 probably use `make-temp-file' instead, except in three circumstances:
767 * If you are creating the file in the user's home directory.
768 * If you are creating a directory rather than an ordinary file.
769 * If you are taking special precautions as `make-temp-file' does. */)
772 return make_temp_name (prefix
, 0);
777 DEFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
778 doc
: /* Convert filename NAME to absolute, and canonicalize it.
779 Second arg DEFAULT-DIRECTORY is directory to start with if NAME is relative
780 \(does not start with slash or tilde); if DEFAULT-DIRECTORY is nil or missing,
781 the current buffer's value of `default-directory' is used.
782 NAME should be a string that is a valid file name for the underlying
784 File name components that are `.' are removed, and
785 so are file name components followed by `..', along with the `..' itself;
786 note that these simplifications are done without checking the resulting
787 file names in the file system.
788 Multiple consecutive slashes are collapsed into a single slash,
789 except at the beginning of the file name when they are significant (e.g.,
790 UNC file names on MS-Windows.)
791 An initial `~/' expands to your home directory.
792 An initial `~USER/' expands to USER's home directory.
793 See also the function `substitute-in-file-name'.
795 For technical reasons, this function can return correct but
796 non-intuitive results for the root directory; for instance,
797 \(expand-file-name ".." "/") returns "/..". For this reason, use
798 \(directory-file-name (file-name-directory dirname)) to traverse a
799 filesystem tree, not (expand-file-name ".." dirname). */)
800 (Lisp_Object name
, Lisp_Object default_directory
)
802 /* These point to SDATA and need to be careful with string-relocation
803 during GC (via DECODE_FILE). */
804 unsigned char *nm
, *newdir
;
805 /* This should only point to alloca'd data. */
806 unsigned char *target
;
812 int collapse_newdir
= 1;
816 Lisp_Object handler
, result
;
822 /* If the file name has special constructs in it,
823 call the corresponding file handler. */
824 handler
= Ffind_file_name_handler (name
, Qexpand_file_name
);
826 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
828 /* Use the buffer's default-directory if DEFAULT_DIRECTORY is omitted. */
829 if (NILP (default_directory
))
830 default_directory
= current_buffer
->directory
;
831 if (! STRINGP (default_directory
))
834 /* "/" is not considered a root directory on DOS_NT, so using "/"
835 here causes an infinite recursion in, e.g., the following:
837 (let (default-directory)
838 (expand-file-name "a"))
840 To avoid this, we set default_directory to the root of the
842 default_directory
= build_string (emacs_root_dir ());
844 default_directory
= build_string ("/");
848 if (!NILP (default_directory
))
850 handler
= Ffind_file_name_handler (default_directory
, Qexpand_file_name
);
852 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
856 unsigned char *o
= SDATA (default_directory
);
858 /* Make sure DEFAULT_DIRECTORY is properly expanded.
859 It would be better to do this down below where we actually use
860 default_directory. Unfortunately, calling Fexpand_file_name recursively
861 could invoke GC, and the strings might be relocated. This would
862 be annoying because we have pointers into strings lying around
863 that would need adjusting, and people would add new pointers to
864 the code and forget to adjust them, resulting in intermittent bugs.
865 Putting this call here avoids all that crud.
867 The EQ test avoids infinite recursion. */
868 if (! NILP (default_directory
) && !EQ (default_directory
, name
)
869 /* Save time in some common cases - as long as default_directory
870 is not relative, it can be canonicalized with name below (if it
871 is needed at all) without requiring it to be expanded now. */
873 /* Detect MSDOS file names with drive specifiers. */
874 && ! (IS_DRIVE (o
[0]) && IS_DEVICE_SEP (o
[1])
875 && IS_DIRECTORY_SEP (o
[2]))
877 /* Detect Windows file names in UNC format. */
878 && ! (IS_DIRECTORY_SEP (o
[0]) && IS_DIRECTORY_SEP (o
[1]))
880 #else /* not DOS_NT */
881 /* Detect Unix absolute file names (/... alone is not absolute on
883 && ! (IS_DIRECTORY_SEP (o
[0]))
884 #endif /* not DOS_NT */
890 default_directory
= Fexpand_file_name (default_directory
, Qnil
);
894 name
= FILE_SYSTEM_CASE (name
);
895 multibyte
= STRING_MULTIBYTE (name
);
896 if (multibyte
!= STRING_MULTIBYTE (default_directory
))
899 default_directory
= string_to_multibyte (default_directory
);
902 name
= string_to_multibyte (name
);
907 /* Make a local copy of nm[] to protect it from GC in DECODE_FILE below. */
908 nm
= (unsigned char *) alloca (SBYTES (name
) + 1);
909 memcpy (nm
, SDATA (name
), SBYTES (name
) + 1);
912 /* Note if special escape prefix is present, but remove for now. */
913 if (nm
[0] == '/' && nm
[1] == ':')
919 /* Find and remove drive specifier if present; this makes nm absolute
920 even if the rest of the name appears to be relative. Only look for
921 drive specifier at the beginning. */
922 if (IS_DRIVE (nm
[0]) && IS_DEVICE_SEP (nm
[1]))
929 /* If we see "c://somedir", we want to strip the first slash after the
930 colon when stripping the drive letter. Otherwise, this expands to
932 if (drive
&& IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
935 /* Discard any previous drive specifier if nm is now in UNC format. */
936 if (IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
940 #endif /* WINDOWSNT */
943 /* If nm is absolute, look for `/./' or `/../' or `//''sequences; if
944 none are found, we can probably return right away. We will avoid
945 allocating a new string if name is already fully expanded. */
947 IS_DIRECTORY_SEP (nm
[0])
949 && drive
&& !is_escaped
952 && (drive
|| IS_DIRECTORY_SEP (nm
[1])) && !is_escaped
956 /* If it turns out that the filename we want to return is just a
957 suffix of FILENAME, we don't need to go through and edit
958 things; we just need to construct a new string using data
959 starting at the middle of FILENAME. If we set lose to a
960 non-zero value, that means we've discovered that we can't do
963 unsigned char *p
= nm
;
967 /* Since we know the name is absolute, we can assume that each
968 element starts with a "/". */
970 /* "." and ".." are hairy. */
971 if (IS_DIRECTORY_SEP (p
[0])
973 && (IS_DIRECTORY_SEP (p
[2])
975 || (p
[2] == '.' && (IS_DIRECTORY_SEP (p
[3])
978 /* We want to replace multiple `/' in a row with a single
981 && IS_DIRECTORY_SEP (p
[0])
982 && IS_DIRECTORY_SEP (p
[1]))
989 /* Make sure directories are all separated with /, but
990 avoid allocation of a new string when not required. */
991 dostounix_filename (nm
);
993 if (IS_DIRECTORY_SEP (nm
[1]))
995 if (strcmp (nm
, SDATA (name
)) != 0)
996 name
= make_specified_string (nm
, -1, strlen (nm
), multibyte
);
1000 /* drive must be set, so this is okay */
1001 if (strcmp (nm
- 2, SDATA (name
)) != 0)
1005 name
= make_specified_string (nm
, -1, p
- nm
, multibyte
);
1006 temp
[0] = DRIVE_LETTER (drive
);
1007 name
= concat2 (build_string (temp
), name
);
1010 #else /* not DOS_NT */
1011 if (strcmp (nm
, SDATA (name
)) == 0)
1013 return make_specified_string (nm
, -1, strlen (nm
), multibyte
);
1014 #endif /* not DOS_NT */
1018 /* At this point, nm might or might not be an absolute file name. We
1019 need to expand ~ or ~user if present, otherwise prefix nm with
1020 default_directory if nm is not absolute, and finally collapse /./
1021 and /foo/../ sequences.
1023 We set newdir to be the appropriate prefix if one is needed:
1024 - the relevant user directory if nm starts with ~ or ~user
1025 - the specified drive's working dir (DOS/NT only) if nm does not
1027 - the value of default_directory.
1029 Note that these prefixes are not guaranteed to be absolute (except
1030 for the working dir of a drive). Therefore, to ensure we always
1031 return an absolute name, if the final prefix is not absolute we
1032 append it to the current working directory. */
1036 if (nm
[0] == '~') /* prefix ~ */
1038 if (IS_DIRECTORY_SEP (nm
[1])
1039 || nm
[1] == 0) /* ~ by itself */
1043 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1044 newdir
= (unsigned char *) "";
1046 /* egetenv may return a unibyte string, which will bite us since
1047 we expect the directory to be multibyte. */
1048 tem
= build_string (newdir
);
1049 if (!STRING_MULTIBYTE (tem
))
1051 hdir
= DECODE_FILE (tem
);
1052 newdir
= SDATA (hdir
);
1055 collapse_newdir
= 0;
1058 else /* ~user/filename */
1060 unsigned char *o
, *p
;
1061 for (p
= nm
; *p
&& (!IS_DIRECTORY_SEP (*p
)); p
++);
1062 o
= alloca (p
- nm
+ 1);
1063 memcpy (o
, nm
, p
- nm
);
1067 pw
= (struct passwd
*) getpwnam (o
+ 1);
1071 newdir
= (unsigned char *) pw
-> pw_dir
;
1074 collapse_newdir
= 0;
1078 /* If we don't find a user of that name, leave the name
1079 unchanged; don't move nm forward to p. */
1084 /* On DOS and Windows, nm is absolute if a drive name was specified;
1085 use the drive's current directory as the prefix if needed. */
1086 if (!newdir
&& drive
)
1088 /* Get default directory if needed to make nm absolute. */
1089 if (!IS_DIRECTORY_SEP (nm
[0]))
1091 newdir
= alloca (MAXPATHLEN
+ 1);
1092 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1097 /* Either nm starts with /, or drive isn't mounted. */
1098 newdir
= alloca (4);
1099 newdir
[0] = DRIVE_LETTER (drive
);
1107 /* Finally, if no prefix has been specified and nm is not absolute,
1108 then it must be expanded relative to default_directory. */
1112 /* /... alone is not absolute on DOS and Windows. */
1113 && !IS_DIRECTORY_SEP (nm
[0])
1116 && !(IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1120 newdir
= SDATA (default_directory
);
1122 /* Note if special escape prefix is present, but remove for now. */
1123 if (newdir
[0] == '/' && newdir
[1] == ':')
1134 /* First ensure newdir is an absolute name. */
1136 /* Detect MSDOS file names with drive specifiers. */
1137 ! (IS_DRIVE (newdir
[0])
1138 && IS_DEVICE_SEP (newdir
[1]) && IS_DIRECTORY_SEP (newdir
[2]))
1140 /* Detect Windows file names in UNC format. */
1141 && ! (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1145 /* Effectively, let newdir be (expand-file-name newdir cwd).
1146 Because of the admonition against calling expand-file-name
1147 when we have pointers into lisp strings, we accomplish this
1148 indirectly by prepending newdir to nm if necessary, and using
1149 cwd (or the wd of newdir's drive) as the new newdir. */
1151 if (IS_DRIVE (newdir
[0]) && IS_DEVICE_SEP (newdir
[1]))
1156 if (!IS_DIRECTORY_SEP (nm
[0]))
1158 char * tmp
= alloca (strlen (newdir
) + strlen (nm
) + 2);
1159 file_name_as_directory (tmp
, newdir
);
1163 newdir
= alloca (MAXPATHLEN
+ 1);
1166 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1173 /* Strip off drive name from prefix, if present. */
1174 if (IS_DRIVE (newdir
[0]) && IS_DEVICE_SEP (newdir
[1]))
1180 /* Keep only a prefix from newdir if nm starts with slash
1181 (//server/share for UNC, nothing otherwise). */
1182 if (IS_DIRECTORY_SEP (nm
[0]) && collapse_newdir
)
1185 if (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1188 newdir
= strcpy (alloca (strlen (newdir
) + 1), newdir
);
1190 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1192 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1204 /* Get rid of any slash at the end of newdir, unless newdir is
1205 just / or // (an incomplete UNC name). */
1206 length
= strlen (newdir
);
1207 if (length
> 1 && IS_DIRECTORY_SEP (newdir
[length
- 1])
1209 && !(length
== 2 && IS_DIRECTORY_SEP (newdir
[0]))
1213 unsigned char *temp
= (unsigned char *) alloca (length
);
1214 memcpy (temp
, newdir
, length
- 1);
1215 temp
[length
- 1] = 0;
1223 /* Now concatenate the directory and name to new space in the stack frame */
1224 tlen
+= strlen (nm
) + 1;
1226 /* Reserve space for drive specifier and escape prefix, since either
1227 or both may need to be inserted. (The Microsoft x86 compiler
1228 produces incorrect code if the following two lines are combined.) */
1229 target
= (unsigned char *) alloca (tlen
+ 4);
1231 #else /* not DOS_NT */
1232 target
= (unsigned char *) alloca (tlen
);
1233 #endif /* not DOS_NT */
1238 if (nm
[0] == 0 || IS_DIRECTORY_SEP (nm
[0]))
1241 /* If newdir is effectively "C:/", then the drive letter will have
1242 been stripped and newdir will be "/". Concatenating with an
1243 absolute directory in nm produces "//", which will then be
1244 incorrectly treated as a network share. Ignore newdir in
1245 this case (keeping the drive letter). */
1246 if (!(drive
&& nm
[0] && IS_DIRECTORY_SEP (newdir
[0])
1247 && newdir
[1] == '\0'))
1249 strcpy (target
, newdir
);
1252 file_name_as_directory (target
, newdir
);
1255 strcat (target
, nm
);
1257 /* Now canonicalize by removing `//', `/.' and `/foo/..' if they
1260 unsigned char *p
= target
;
1261 unsigned char *o
= target
;
1265 if (!IS_DIRECTORY_SEP (*p
))
1269 else if (p
[1] == '.'
1270 && (IS_DIRECTORY_SEP (p
[2])
1273 /* If "/." is the entire filename, keep the "/". Otherwise,
1274 just delete the whole "/.". */
1275 if (o
== target
&& p
[2] == '\0')
1279 else if (p
[1] == '.' && p
[2] == '.'
1280 /* `/../' is the "superroot" on certain file systems.
1281 Turned off on DOS_NT systems because they have no
1282 "superroot" and because this causes us to produce
1283 file names like "d:/../foo" which fail file-related
1284 functions of the underlying OS. (To reproduce, try a
1285 long series of "../../" in default_directory, longer
1286 than the number of levels from the root.) */
1290 && (IS_DIRECTORY_SEP (p
[3]) || p
[3] == 0))
1293 unsigned char *prev_o
= o
;
1295 while (o
!= target
&& (--o
) && !IS_DIRECTORY_SEP (*o
))
1298 /* Don't go below server level in UNC filenames. */
1299 if (o
== target
+ 1 && IS_DIRECTORY_SEP (*o
)
1300 && IS_DIRECTORY_SEP (*target
))
1304 /* Keep initial / only if this is the whole name. */
1305 if (o
== target
&& IS_ANY_SEP (*o
) && p
[3] == 0)
1309 else if (p
> target
&& IS_DIRECTORY_SEP (p
[1]))
1310 /* Collapse multiple `/' in a row. */
1319 /* At last, set drive name. */
1321 /* Except for network file name. */
1322 if (!(IS_DIRECTORY_SEP (target
[0]) && IS_DIRECTORY_SEP (target
[1])))
1323 #endif /* WINDOWSNT */
1325 if (!drive
) abort ();
1327 target
[0] = DRIVE_LETTER (drive
);
1330 /* Reinsert the escape prefix if required. */
1337 dostounix_filename (target
);
1340 result
= make_specified_string (target
, -1, o
- target
, multibyte
);
1343 /* Again look to see if the file name has special constructs in it
1344 and perhaps call the corresponding file handler. This is needed
1345 for filenames such as "/foo/../user@host:/bar/../baz". Expanding
1346 the ".." component gives us "/user@host:/bar/../baz" which needs
1347 to be expanded again. */
1348 handler
= Ffind_file_name_handler (result
, Qexpand_file_name
);
1349 if (!NILP (handler
))
1350 return call3 (handler
, Qexpand_file_name
, result
, default_directory
);
1356 /* PLEASE DO NOT DELETE THIS COMMENTED-OUT VERSION!
1357 This is the old version of expand-file-name, before it was thoroughly
1358 rewritten for Emacs 10.31. We leave this version here commented-out,
1359 because the code is very complex and likely to have subtle bugs. If
1360 bugs _are_ found, it might be of interest to look at the old code and
1361 see what did it do in the relevant situation.
1363 Don't remove this code: it's true that it will be accessible
1364 from the repository, but a few years from deletion, people will
1365 forget it is there. */
1367 /* Changed this DEFUN to a DEAFUN, so as not to confuse `make-docfile'. */
1368 DEAFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
1369 "Convert FILENAME to absolute, and canonicalize it.\n\
1370 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
1371 \(does not start with slash); if DEFAULT is nil or missing,\n\
1372 the current buffer's value of default-directory is used.\n\
1373 Filenames containing `.' or `..' as components are simplified;\n\
1374 initial `~/' expands to your home directory.\n\
1375 See also the function `substitute-in-file-name'.")
1377 Lisp_Object name
, defalt
;
1381 register unsigned char *newdir
, *p
, *o
;
1383 unsigned char *target
;
1387 CHECK_STRING (name
);
1390 /* If nm is absolute, flush ...// and detect /./ and /../.
1391 If no /./ or /../ we can return right away. */
1398 if (p
[0] == '/' && p
[1] == '/'
1401 if (p
[0] == '/' && p
[1] == '~')
1402 nm
= p
+ 1, lose
= 1;
1403 if (p
[0] == '/' && p
[1] == '.'
1404 && (p
[2] == '/' || p
[2] == 0
1405 || (p
[2] == '.' && (p
[3] == '/' || p
[3] == 0))))
1411 if (nm
== SDATA (name
))
1413 return build_string (nm
);
1417 /* Now determine directory to start with and put it in NEWDIR */
1421 if (nm
[0] == '~') /* prefix ~ */
1422 if (nm
[1] == '/' || nm
[1] == 0)/* ~/filename */
1424 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1425 newdir
= (unsigned char *) "";
1428 else /* ~user/filename */
1430 /* Get past ~ to user */
1431 unsigned char *user
= nm
+ 1;
1432 /* Find end of name. */
1433 unsigned char *ptr
= (unsigned char *) strchr (user
, '/');
1434 int len
= ptr
? ptr
- user
: strlen (user
);
1435 /* Copy the user name into temp storage. */
1436 o
= (unsigned char *) alloca (len
+ 1);
1437 memcpy (o
, user
, len
);
1440 /* Look up the user name. */
1442 pw
= (struct passwd
*) getpwnam (o
+ 1);
1445 error ("\"%s\" isn't a registered user", o
+ 1);
1447 newdir
= (unsigned char *) pw
->pw_dir
;
1449 /* Discard the user name from NM. */
1453 if (nm
[0] != '/' && !newdir
)
1456 defalt
= current_buffer
->directory
;
1457 CHECK_STRING (defalt
);
1458 newdir
= SDATA (defalt
);
1461 /* Now concatenate the directory and name to new space in the stack frame */
1463 tlen
= (newdir
? strlen (newdir
) + 1 : 0) + strlen (nm
) + 1;
1464 target
= (unsigned char *) alloca (tlen
);
1469 if (nm
[0] == 0 || nm
[0] == '/')
1470 strcpy (target
, newdir
);
1472 file_name_as_directory (target
, newdir
);
1475 strcat (target
, nm
);
1477 /* Now canonicalize by removing /. and /foo/.. if they appear */
1488 else if (!strncmp (p
, "//", 2)
1494 else if (p
[0] == '/' && p
[1] == '.'
1495 && (p
[2] == '/' || p
[2] == 0))
1497 else if (!strncmp (p
, "/..", 3)
1498 /* `/../' is the "superroot" on certain file systems. */
1500 && (p
[3] == '/' || p
[3] == 0))
1502 while (o
!= target
&& *--o
!= '/')
1504 if (o
== target
&& *o
== '/')
1514 return make_string (target
, o
- target
);
1518 /* If /~ or // appears, discard everything through first slash. */
1520 file_name_absolute_p (const unsigned char *filename
)
1523 (IS_DIRECTORY_SEP (*filename
) || *filename
== '~'
1525 || (IS_DRIVE (*filename
) && IS_DEVICE_SEP (filename
[1])
1526 && IS_DIRECTORY_SEP (filename
[2]))
1531 static unsigned char *
1532 search_embedded_absfilename (unsigned char *nm
, unsigned char *endp
)
1534 unsigned char *p
, *s
;
1536 for (p
= nm
+ 1; p
< endp
; p
++)
1539 || IS_DIRECTORY_SEP (p
[-1]))
1540 && file_name_absolute_p (p
)
1541 #if defined (WINDOWSNT) || defined(CYGWIN)
1542 /* // at start of file name is meaningful in Apollo,
1543 WindowsNT and Cygwin systems. */
1544 && !(IS_DIRECTORY_SEP (p
[0]) && p
- 1 == nm
)
1545 #endif /* not (WINDOWSNT || CYGWIN) */
1548 for (s
= p
; *s
&& (!IS_DIRECTORY_SEP (*s
)); s
++);
1549 if (p
[0] == '~' && s
> p
+ 1) /* we've got "/~something/" */
1551 unsigned char *o
= alloca (s
- p
+ 1);
1553 memcpy (o
, p
, s
- p
);
1556 /* If we have ~user and `user' exists, discard
1557 everything up to ~. But if `user' does not exist, leave
1558 ~user alone, it might be a literal file name. */
1560 pw
= getpwnam (o
+ 1);
1572 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name
,
1573 Ssubstitute_in_file_name
, 1, 1, 0,
1574 doc
: /* Substitute environment variables referred to in FILENAME.
1575 `$FOO' where FOO is an environment variable name means to substitute
1576 the value of that variable. The variable name should be terminated
1577 with a character not a letter, digit or underscore; otherwise, enclose
1578 the entire variable name in braces.
1580 If `/~' appears, all of FILENAME through that `/' is discarded.
1581 If `//' appears, everything up to and including the first of
1582 those `/' is discarded. */)
1583 (Lisp_Object filename
)
1587 register unsigned char *s
, *p
, *o
, *x
, *endp
;
1588 unsigned char *target
= NULL
;
1590 int substituted
= 0;
1593 Lisp_Object handler
;
1595 CHECK_STRING (filename
);
1597 multibyte
= STRING_MULTIBYTE (filename
);
1599 /* If the file name has special constructs in it,
1600 call the corresponding file handler. */
1601 handler
= Ffind_file_name_handler (filename
, Qsubstitute_in_file_name
);
1602 if (!NILP (handler
))
1603 return call2 (handler
, Qsubstitute_in_file_name
, filename
);
1605 /* Always work on a copy of the string, in case GC happens during
1606 decode of environment variables, causing the original Lisp_String
1607 data to be relocated. */
1608 nm
= (unsigned char *) alloca (SBYTES (filename
) + 1);
1609 memcpy (nm
, SDATA (filename
), SBYTES (filename
) + 1);
1612 dostounix_filename (nm
);
1613 substituted
= (strcmp (nm
, SDATA (filename
)) != 0);
1615 endp
= nm
+ SBYTES (filename
);
1617 /* If /~ or // appears, discard everything through first slash. */
1618 p
= search_embedded_absfilename (nm
, endp
);
1620 /* Start over with the new string, so we check the file-name-handler
1621 again. Important with filenames like "/home/foo//:/hello///there"
1622 which whould substitute to "/:/hello///there" rather than "/there". */
1623 return Fsubstitute_in_file_name
1624 (make_specified_string (p
, -1, endp
- p
, multibyte
));
1626 /* See if any variables are substituted into the string
1627 and find the total length of their values in `total' */
1629 for (p
= nm
; p
!= endp
;)
1639 /* "$$" means a single "$" */
1648 while (p
!= endp
&& *p
!= '}') p
++;
1649 if (*p
!= '}') goto missingclose
;
1655 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1659 /* Copy out the variable name */
1660 target
= (unsigned char *) alloca (s
- o
+ 1);
1661 strncpy (target
, o
, s
- o
);
1664 strupr (target
); /* $home == $HOME etc. */
1667 /* Get variable value */
1668 o
= (unsigned char *) egetenv (target
);
1671 /* Don't try to guess a maximum length - UTF8 can use up to
1672 four bytes per character. This code is unlikely to run
1673 in a situation that requires performance, so decoding the
1674 env variables twice should be acceptable. Note that
1675 decoding may cause a garbage collect. */
1676 Lisp_Object orig
, decoded
;
1677 orig
= make_unibyte_string (o
, strlen (o
));
1678 decoded
= DECODE_FILE (orig
);
1679 total
+= SBYTES (decoded
);
1689 /* If substitution required, recopy the string and do it */
1690 /* Make space in stack frame for the new copy */
1691 xnm
= (unsigned char *) alloca (SBYTES (filename
) + total
+ 1);
1694 /* Copy the rest of the name through, replacing $ constructs with values */
1711 while (p
!= endp
&& *p
!= '}') p
++;
1712 if (*p
!= '}') goto missingclose
;
1718 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1722 /* Copy out the variable name */
1723 target
= (unsigned char *) alloca (s
- o
+ 1);
1724 strncpy (target
, o
, s
- o
);
1727 strupr (target
); /* $home == $HOME etc. */
1730 /* Get variable value */
1731 o
= (unsigned char *) egetenv (target
);
1735 strcpy (x
, target
); x
+= strlen (target
);
1739 Lisp_Object orig
, decoded
;
1740 int orig_length
, decoded_length
;
1741 orig_length
= strlen (o
);
1742 orig
= make_unibyte_string (o
, orig_length
);
1743 decoded
= DECODE_FILE (orig
);
1744 decoded_length
= SBYTES (decoded
);
1745 strncpy (x
, SDATA (decoded
), decoded_length
);
1746 x
+= decoded_length
;
1748 /* If environment variable needed decoding, return value
1749 needs to be multibyte. */
1750 if (decoded_length
!= orig_length
1751 || strncmp (SDATA (decoded
), o
, orig_length
))
1758 /* If /~ or // appears, discard everything through first slash. */
1759 while ((p
= search_embedded_absfilename (xnm
, x
)))
1760 /* This time we do not start over because we've already expanded envvars
1761 and replaced $$ with $. Maybe we should start over as well, but we'd
1762 need to quote some $ to $$ first. */
1765 return make_specified_string (xnm
, -1, x
- xnm
, multibyte
);
1768 error ("Bad format environment-variable substitution");
1770 error ("Missing \"}\" in environment-variable substitution");
1772 error ("Substituting nonexistent environment variable \"%s\"", target
);
1778 /* A slightly faster and more convenient way to get
1779 (directory-file-name (expand-file-name FOO)). */
1782 expand_and_dir_to_file (Lisp_Object filename
, Lisp_Object defdir
)
1784 register Lisp_Object absname
;
1786 absname
= Fexpand_file_name (filename
, defdir
);
1788 /* Remove final slash, if any (unless this is the root dir).
1789 stat behaves differently depending! */
1790 if (SCHARS (absname
) > 1
1791 && IS_DIRECTORY_SEP (SREF (absname
, SBYTES (absname
) - 1))
1792 && !IS_DEVICE_SEP (SREF (absname
, SBYTES (absname
)-2)))
1793 /* We cannot take shortcuts; they might be wrong for magic file names. */
1794 absname
= Fdirectory_file_name (absname
);
1798 /* Signal an error if the file ABSNAME already exists.
1799 If INTERACTIVE is nonzero, ask the user whether to proceed,
1800 and bypass the error if the user says to go ahead.
1801 QUERYSTRING is a name for the action that is being considered
1804 *STATPTR is used to store the stat information if the file exists.
1805 If the file does not exist, STATPTR->st_mode is set to 0.
1806 If STATPTR is null, we don't store into it.
1808 If QUICK is nonzero, we ask for y or n, not yes or no. */
1811 barf_or_query_if_file_exists (Lisp_Object absname
, const unsigned char *querystring
, int interactive
, struct stat
*statptr
, int quick
)
1813 register Lisp_Object tem
, encoded_filename
;
1814 struct stat statbuf
;
1815 struct gcpro gcpro1
;
1817 encoded_filename
= ENCODE_FILE (absname
);
1819 /* stat is a good way to tell whether the file exists,
1820 regardless of what access permissions it has. */
1821 if (lstat (SDATA (encoded_filename
), &statbuf
) >= 0)
1824 xsignal2 (Qfile_already_exists
,
1825 build_string ("File already exists"), absname
);
1827 tem
= format2 ("File %s already exists; %s anyway? ",
1828 absname
, build_string (querystring
));
1830 tem
= call1 (intern ("y-or-n-p"), tem
);
1832 tem
= do_yes_or_no_p (tem
);
1835 xsignal2 (Qfile_already_exists
,
1836 build_string ("File already exists"), absname
);
1843 statptr
->st_mode
= 0;
1848 DEFUN ("copy-file", Fcopy_file
, Scopy_file
, 2, 6,
1849 "fCopy file: \nGCopy %s to file: \np\nP",
1850 doc
: /* Copy FILE to NEWNAME. Both args must be strings.
1851 If NEWNAME names a directory, copy FILE there.
1853 This function always sets the file modes of the output file to match
1856 The optional third argument OK-IF-ALREADY-EXISTS specifies what to do
1857 if file NEWNAME already exists. If OK-IF-ALREADY-EXISTS is nil, we
1858 signal a `file-already-exists' error without overwriting. If
1859 OK-IF-ALREADY-EXISTS is a number, we request confirmation from the user
1860 about overwriting; this is what happens in interactive use with M-x.
1861 Any other value for OK-IF-ALREADY-EXISTS means to overwrite the
1864 Fourth arg KEEP-TIME non-nil means give the output file the same
1865 last-modified time as the old one. (This works on only some systems.)
1867 A prefix arg makes KEEP-TIME non-nil.
1869 If PRESERVE-UID-GID is non-nil, we try to transfer the
1870 uid and gid of FILE to NEWNAME.
1872 If PRESERVE-SELINUX-CONTEXT is non-nil and SELinux is enabled
1873 on the system, we copy the SELinux context of FILE to NEWNAME. */)
1874 (Lisp_Object file
, Lisp_Object newname
, Lisp_Object ok_if_already_exists
, Lisp_Object keep_time
, Lisp_Object preserve_uid_gid
, Lisp_Object preserve_selinux_context
)
1877 char buf
[16 * 1024];
1878 struct stat st
, out_st
;
1879 Lisp_Object handler
;
1880 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1881 int count
= SPECPDL_INDEX ();
1882 int input_file_statable_p
;
1883 Lisp_Object encoded_file
, encoded_newname
;
1885 security_context_t con
;
1886 int fail
, conlength
= 0;
1889 encoded_file
= encoded_newname
= Qnil
;
1890 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
1891 CHECK_STRING (file
);
1892 CHECK_STRING (newname
);
1894 if (!NILP (Ffile_directory_p (newname
)))
1895 newname
= Fexpand_file_name (Ffile_name_nondirectory (file
), newname
);
1897 newname
= Fexpand_file_name (newname
, Qnil
);
1899 file
= Fexpand_file_name (file
, Qnil
);
1901 /* If the input file name has special constructs in it,
1902 call the corresponding file handler. */
1903 handler
= Ffind_file_name_handler (file
, Qcopy_file
);
1904 /* Likewise for output file name. */
1906 handler
= Ffind_file_name_handler (newname
, Qcopy_file
);
1907 if (!NILP (handler
))
1908 RETURN_UNGCPRO (call7 (handler
, Qcopy_file
, file
, newname
,
1909 ok_if_already_exists
, keep_time
, preserve_uid_gid
,
1910 preserve_selinux_context
));
1912 encoded_file
= ENCODE_FILE (file
);
1913 encoded_newname
= ENCODE_FILE (newname
);
1915 if (NILP (ok_if_already_exists
)
1916 || INTEGERP (ok_if_already_exists
))
1917 barf_or_query_if_file_exists (newname
, "copy to it",
1918 INTEGERP (ok_if_already_exists
), &out_st
, 0);
1919 else if (stat (SDATA (encoded_newname
), &out_st
) < 0)
1923 if (!CopyFile (SDATA (encoded_file
),
1924 SDATA (encoded_newname
),
1926 report_file_error ("Copying file", Fcons (file
, Fcons (newname
, Qnil
)));
1927 /* CopyFile retains the timestamp by default. */
1928 else if (NILP (keep_time
))
1934 EMACS_GET_TIME (now
);
1935 filename
= SDATA (encoded_newname
);
1937 /* Ensure file is writable while its modified time is set. */
1938 attributes
= GetFileAttributes (filename
);
1939 SetFileAttributes (filename
, attributes
& ~FILE_ATTRIBUTE_READONLY
);
1940 if (set_file_times (filename
, now
, now
))
1942 /* Restore original attributes. */
1943 SetFileAttributes (filename
, attributes
);
1944 xsignal2 (Qfile_date_error
,
1945 build_string ("Cannot set file date"), newname
);
1947 /* Restore original attributes. */
1948 SetFileAttributes (filename
, attributes
);
1950 #else /* not WINDOWSNT */
1952 ifd
= emacs_open (SDATA (encoded_file
), O_RDONLY
, 0);
1956 report_file_error ("Opening input file", Fcons (file
, Qnil
));
1958 record_unwind_protect (close_file_unwind
, make_number (ifd
));
1960 /* We can only copy regular files and symbolic links. Other files are not
1962 input_file_statable_p
= (fstat (ifd
, &st
) >= 0);
1965 if (!NILP (preserve_selinux_context
) && is_selinux_enabled ())
1967 conlength
= fgetfilecon (ifd
, &con
);
1968 if (conlength
== -1)
1969 report_file_error ("Doing fgetfilecon", Fcons (file
, Qnil
));
1973 if (out_st
.st_mode
!= 0
1974 && st
.st_dev
== out_st
.st_dev
&& st
.st_ino
== out_st
.st_ino
)
1977 report_file_error ("Input and output files are the same",
1978 Fcons (file
, Fcons (newname
, Qnil
)));
1981 #if defined (S_ISREG) && defined (S_ISLNK)
1982 if (input_file_statable_p
)
1984 if (!(S_ISREG (st
.st_mode
)) && !(S_ISLNK (st
.st_mode
)))
1986 #if defined (EISDIR)
1987 /* Get a better looking error message. */
1990 report_file_error ("Non-regular file", Fcons (file
, Qnil
));
1993 #endif /* S_ISREG && S_ISLNK */
1996 /* System's default file type was set to binary by _fmode in emacs.c. */
1997 ofd
= emacs_open (SDATA (encoded_newname
),
1998 O_WRONLY
| O_TRUNC
| O_CREAT
1999 | (NILP (ok_if_already_exists
) ? O_EXCL
: 0),
2000 S_IREAD
| S_IWRITE
);
2001 #else /* not MSDOS */
2002 ofd
= emacs_open (SDATA (encoded_newname
),
2003 O_WRONLY
| O_TRUNC
| O_CREAT
2004 | (NILP (ok_if_already_exists
) ? O_EXCL
: 0),
2006 #endif /* not MSDOS */
2008 report_file_error ("Opening output file", Fcons (newname
, Qnil
));
2010 record_unwind_protect (close_file_unwind
, make_number (ofd
));
2014 while ((n
= emacs_read (ifd
, buf
, sizeof buf
)) > 0)
2015 if (emacs_write (ofd
, buf
, n
) != n
)
2016 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2020 /* Preserve the original file modes, and if requested, also its
2022 if (input_file_statable_p
)
2024 if (! NILP (preserve_uid_gid
))
2025 fchown (ofd
, st
.st_uid
, st
.st_gid
);
2026 fchmod (ofd
, st
.st_mode
& 07777);
2028 #endif /* not MSDOS */
2033 /* Set the modified context back to the file. */
2034 fail
= fsetfilecon (ofd
, con
);
2036 report_file_error ("Doing fsetfilecon", Fcons (newname
, Qnil
));
2042 /* Closing the output clobbers the file times on some systems. */
2043 if (emacs_close (ofd
) < 0)
2044 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2046 if (input_file_statable_p
)
2048 if (!NILP (keep_time
))
2050 EMACS_TIME atime
, mtime
;
2051 EMACS_SET_SECS_USECS (atime
, st
.st_atime
, 0);
2052 EMACS_SET_SECS_USECS (mtime
, st
.st_mtime
, 0);
2053 if (set_file_times (SDATA (encoded_newname
),
2055 xsignal2 (Qfile_date_error
,
2056 build_string ("Cannot set file date"), newname
);
2063 if (input_file_statable_p
)
2065 /* In DJGPP v2.0 and later, fstat usually returns true file mode bits,
2066 and if it can't, it tells so. Otherwise, under MSDOS we usually
2067 get only the READ bit, which will make the copied file read-only,
2068 so it's better not to chmod at all. */
2069 if ((_djstat_flags
& _STFAIL_WRITEBIT
) == 0)
2070 chmod (SDATA (encoded_newname
), st
.st_mode
& 07777);
2073 #endif /* not WINDOWSNT */
2075 /* Discard the unwind protects. */
2076 specpdl_ptr
= specpdl
+ count
;
2082 DEFUN ("make-directory-internal", Fmake_directory_internal
,
2083 Smake_directory_internal
, 1, 1, 0,
2084 doc
: /* Create a new directory named DIRECTORY. */)
2085 (Lisp_Object directory
)
2087 const unsigned char *dir
;
2088 Lisp_Object handler
;
2089 Lisp_Object encoded_dir
;
2091 CHECK_STRING (directory
);
2092 directory
= Fexpand_file_name (directory
, Qnil
);
2094 handler
= Ffind_file_name_handler (directory
, Qmake_directory_internal
);
2095 if (!NILP (handler
))
2096 return call2 (handler
, Qmake_directory_internal
, directory
);
2098 encoded_dir
= ENCODE_FILE (directory
);
2100 dir
= SDATA (encoded_dir
);
2103 if (mkdir (dir
) != 0)
2105 if (mkdir (dir
, 0777) != 0)
2107 report_file_error ("Creating directory", list1 (directory
));
2112 DEFUN ("delete-directory-internal", Fdelete_directory_internal
,
2113 Sdelete_directory_internal
, 1, 1, 0,
2114 doc
: /* Delete the directory named DIRECTORY. Does not follow symlinks. */)
2115 (Lisp_Object directory
)
2117 const unsigned char *dir
;
2118 Lisp_Object handler
;
2119 Lisp_Object encoded_dir
;
2121 CHECK_STRING (directory
);
2122 directory
= Fdirectory_file_name (Fexpand_file_name (directory
, Qnil
));
2123 encoded_dir
= ENCODE_FILE (directory
);
2124 dir
= SDATA (encoded_dir
);
2126 if (rmdir (dir
) != 0)
2127 report_file_error ("Removing directory", list1 (directory
));
2132 DEFUN ("delete-file", Fdelete_file
, Sdelete_file
, 1, 2,
2133 "(list (read-file-name \
2134 (if (and delete-by-moving-to-trash (null current-prefix-arg)) \
2135 \"Move file to trash: \" \"Delete file: \") \
2136 nil default-directory (confirm-nonexistent-file-or-buffer)) \
2137 (null current-prefix-arg))",
2138 doc
: /* Delete file named FILENAME. If it is a symlink, remove the symlink.
2139 If file has multiple names, it continues to exist with the other names.
2140 TRASH non-nil means to trash the file instead of deleting, provided
2141 `delete-by-moving-to-trash' is non-nil.
2143 When called interactively, TRASH is t if no prefix argument is given.
2144 With a prefix argument, TRASH is nil. */)
2145 (Lisp_Object filename
, Lisp_Object trash
)
2147 Lisp_Object handler
;
2148 Lisp_Object encoded_file
;
2149 struct gcpro gcpro1
;
2152 if (!NILP (Ffile_directory_p (filename
))
2153 && NILP (Ffile_symlink_p (filename
)))
2154 xsignal2 (Qfile_error
,
2155 build_string ("Removing old name: is a directory"),
2158 filename
= Fexpand_file_name (filename
, Qnil
);
2160 handler
= Ffind_file_name_handler (filename
, Qdelete_file
);
2161 if (!NILP (handler
))
2162 return call3 (handler
, Qdelete_file
, filename
, trash
);
2164 if (delete_by_moving_to_trash
&& !NILP (trash
))
2165 return call1 (Qmove_file_to_trash
, filename
);
2167 encoded_file
= ENCODE_FILE (filename
);
2169 if (0 > unlink (SDATA (encoded_file
)))
2170 report_file_error ("Removing old name", list1 (filename
));
2175 internal_delete_file_1 (Lisp_Object ignore
)
2180 /* Delete file FILENAME, returning 1 if successful and 0 if failed.
2181 This ignores `delete-by-moving-to-trash'. */
2184 internal_delete_file (Lisp_Object filename
)
2188 tem
= internal_condition_case_2 (Fdelete_file
, filename
, Qnil
,
2189 Qt
, internal_delete_file_1
);
2193 DEFUN ("rename-file", Frename_file
, Srename_file
, 2, 3,
2194 "fRename file: \nGRename %s to file: \np",
2195 doc
: /* Rename FILE as NEWNAME. Both args must be strings.
2196 If file has names other than FILE, it continues to have those names.
2197 Signals a `file-already-exists' error if a file NEWNAME already exists
2198 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
2199 A number as third arg means request confirmation if NEWNAME already exists.
2200 This is what happens in interactive use with M-x. */)
2201 (Lisp_Object file
, Lisp_Object newname
, Lisp_Object ok_if_already_exists
)
2203 Lisp_Object handler
;
2204 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
2205 Lisp_Object encoded_file
, encoded_newname
, symlink_target
;
2207 symlink_target
= encoded_file
= encoded_newname
= Qnil
;
2208 GCPRO5 (file
, newname
, encoded_file
, encoded_newname
, symlink_target
);
2209 CHECK_STRING (file
);
2210 CHECK_STRING (newname
);
2211 file
= Fexpand_file_name (file
, Qnil
);
2213 if ((!NILP (Ffile_directory_p (newname
)))
2215 /* If the file names are identical but for the case,
2216 don't attempt to move directory to itself. */
2217 && (NILP (Fstring_equal (Fdowncase (file
), Fdowncase (newname
))))
2221 Lisp_Object fname
= NILP (Ffile_directory_p (file
))
2222 ? file
: Fdirectory_file_name (file
);
2223 newname
= Fexpand_file_name (Ffile_name_nondirectory (fname
), newname
);
2226 newname
= Fexpand_file_name (newname
, Qnil
);
2228 /* If the file name has special constructs in it,
2229 call the corresponding file handler. */
2230 handler
= Ffind_file_name_handler (file
, Qrename_file
);
2232 handler
= Ffind_file_name_handler (newname
, Qrename_file
);
2233 if (!NILP (handler
))
2234 RETURN_UNGCPRO (call4 (handler
, Qrename_file
,
2235 file
, newname
, ok_if_already_exists
));
2237 encoded_file
= ENCODE_FILE (file
);
2238 encoded_newname
= ENCODE_FILE (newname
);
2241 /* If the file names are identical but for the case, don't ask for
2242 confirmation: they simply want to change the letter-case of the
2244 if (NILP (Fstring_equal (Fdowncase (file
), Fdowncase (newname
))))
2246 if (NILP (ok_if_already_exists
)
2247 || INTEGERP (ok_if_already_exists
))
2248 barf_or_query_if_file_exists (newname
, "rename to it",
2249 INTEGERP (ok_if_already_exists
), 0, 0);
2250 if (0 > rename (SDATA (encoded_file
), SDATA (encoded_newname
)))
2256 symlink_target
= Ffile_symlink_p (file
);
2257 if (! NILP (symlink_target
))
2258 Fmake_symbolic_link (symlink_target
, newname
,
2259 NILP (ok_if_already_exists
) ? Qnil
: Qt
);
2262 if (!NILP (Ffile_directory_p (file
)))
2263 call4 (Qcopy_directory
, file
, newname
, Qt
, Qnil
);
2265 /* We have already prompted if it was an integer, so don't
2266 have copy-file prompt again. */
2267 Fcopy_file (file
, newname
,
2268 NILP (ok_if_already_exists
) ? Qnil
: Qt
,
2271 count
= SPECPDL_INDEX ();
2272 specbind (Qdelete_by_moving_to_trash
, Qnil
);
2274 if (!NILP (Ffile_directory_p (file
))
2276 && NILP (symlink_target
)
2279 call2 (Qdelete_directory
, file
, Qt
);
2281 Fdelete_file (file
, Qnil
);
2282 unbind_to (count
, Qnil
);
2285 report_file_error ("Renaming", list2 (file
, newname
));
2291 DEFUN ("add-name-to-file", Fadd_name_to_file
, Sadd_name_to_file
, 2, 3,
2292 "fAdd name to file: \nGName to add to %s: \np",
2293 doc
: /* Give FILE additional name NEWNAME. Both args must be strings.
2294 Signals a `file-already-exists' error if a file NEWNAME already exists
2295 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
2296 A number as third arg means request confirmation if NEWNAME already exists.
2297 This is what happens in interactive use with M-x. */)
2298 (Lisp_Object file
, Lisp_Object newname
, Lisp_Object ok_if_already_exists
)
2300 Lisp_Object handler
;
2301 Lisp_Object encoded_file
, encoded_newname
;
2302 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2304 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2305 encoded_file
= encoded_newname
= Qnil
;
2306 CHECK_STRING (file
);
2307 CHECK_STRING (newname
);
2308 file
= Fexpand_file_name (file
, Qnil
);
2310 if (!NILP (Ffile_directory_p (newname
)))
2311 newname
= Fexpand_file_name (Ffile_name_nondirectory (file
), newname
);
2313 newname
= Fexpand_file_name (newname
, Qnil
);
2315 /* If the file name has special constructs in it,
2316 call the corresponding file handler. */
2317 handler
= Ffind_file_name_handler (file
, Qadd_name_to_file
);
2318 if (!NILP (handler
))
2319 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2320 newname
, ok_if_already_exists
));
2322 /* If the new name has special constructs in it,
2323 call the corresponding file handler. */
2324 handler
= Ffind_file_name_handler (newname
, Qadd_name_to_file
);
2325 if (!NILP (handler
))
2326 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2327 newname
, ok_if_already_exists
));
2329 encoded_file
= ENCODE_FILE (file
);
2330 encoded_newname
= ENCODE_FILE (newname
);
2332 if (NILP (ok_if_already_exists
)
2333 || INTEGERP (ok_if_already_exists
))
2334 barf_or_query_if_file_exists (newname
, "make it a new name",
2335 INTEGERP (ok_if_already_exists
), 0, 0);
2337 unlink (SDATA (newname
));
2338 if (0 > link (SDATA (encoded_file
), SDATA (encoded_newname
)))
2339 report_file_error ("Adding new name", list2 (file
, newname
));
2345 DEFUN ("make-symbolic-link", Fmake_symbolic_link
, Smake_symbolic_link
, 2, 3,
2346 "FMake symbolic link to file: \nGMake symbolic link to file %s: \np",
2347 doc
: /* Make a symbolic link to FILENAME, named LINKNAME.
2348 Both args must be strings.
2349 Signals a `file-already-exists' error if a file LINKNAME already exists
2350 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
2351 A number as third arg means request confirmation if LINKNAME already exists.
2352 This happens for interactive use with M-x. */)
2353 (Lisp_Object filename
, Lisp_Object linkname
, Lisp_Object ok_if_already_exists
)
2355 Lisp_Object handler
;
2356 Lisp_Object encoded_filename
, encoded_linkname
;
2357 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2359 GCPRO4 (filename
, linkname
, encoded_filename
, encoded_linkname
);
2360 encoded_filename
= encoded_linkname
= Qnil
;
2361 CHECK_STRING (filename
);
2362 CHECK_STRING (linkname
);
2363 /* If the link target has a ~, we must expand it to get
2364 a truly valid file name. Otherwise, do not expand;
2365 we want to permit links to relative file names. */
2366 if (SREF (filename
, 0) == '~')
2367 filename
= Fexpand_file_name (filename
, Qnil
);
2369 if (!NILP (Ffile_directory_p (linkname
)))
2370 linkname
= Fexpand_file_name (Ffile_name_nondirectory (filename
), linkname
);
2372 linkname
= Fexpand_file_name (linkname
, Qnil
);
2374 /* If the file name has special constructs in it,
2375 call the corresponding file handler. */
2376 handler
= Ffind_file_name_handler (filename
, Qmake_symbolic_link
);
2377 if (!NILP (handler
))
2378 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2379 linkname
, ok_if_already_exists
));
2381 /* If the new link name has special constructs in it,
2382 call the corresponding file handler. */
2383 handler
= Ffind_file_name_handler (linkname
, Qmake_symbolic_link
);
2384 if (!NILP (handler
))
2385 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2386 linkname
, ok_if_already_exists
));
2389 encoded_filename
= ENCODE_FILE (filename
);
2390 encoded_linkname
= ENCODE_FILE (linkname
);
2392 if (NILP (ok_if_already_exists
)
2393 || INTEGERP (ok_if_already_exists
))
2394 barf_or_query_if_file_exists (linkname
, "make it a link",
2395 INTEGERP (ok_if_already_exists
), 0, 0);
2396 if (0 > symlink (SDATA (encoded_filename
),
2397 SDATA (encoded_linkname
)))
2399 /* If we didn't complain already, silently delete existing file. */
2400 if (errno
== EEXIST
)
2402 unlink (SDATA (encoded_linkname
));
2403 if (0 <= symlink (SDATA (encoded_filename
),
2404 SDATA (encoded_linkname
)))
2411 report_file_error ("Making symbolic link", list2 (filename
, linkname
));
2418 xsignal1 (Qfile_error
, build_string ("Symbolic links are not supported"));
2420 #endif /* S_IFLNK */
2424 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p
, Sfile_name_absolute_p
,
2426 doc
: /* Return t if file FILENAME specifies an absolute file name.
2427 On Unix, this is a name starting with a `/' or a `~'. */)
2428 (Lisp_Object filename
)
2430 CHECK_STRING (filename
);
2431 return file_name_absolute_p (SDATA (filename
)) ? Qt
: Qnil
;
2434 /* Return nonzero if file FILENAME exists and can be executed. */
2437 check_executable (char *filename
)
2440 int len
= strlen (filename
);
2443 if (stat (filename
, &st
) < 0)
2445 return ((st
.st_mode
& S_IEXEC
) != 0);
2446 #else /* not DOS_NT */
2447 #ifdef HAVE_EUIDACCESS
2448 return (euidaccess (filename
, 1) >= 0);
2450 /* Access isn't quite right because it uses the real uid
2451 and we really want to test with the effective uid.
2452 But Unix doesn't give us a right way to do it. */
2453 return (access (filename
, 1) >= 0);
2455 #endif /* not DOS_NT */
2458 /* Return nonzero if file FILENAME exists and can be written. */
2461 check_writable (const char *filename
)
2465 if (stat (filename
, &st
) < 0)
2467 return (st
.st_mode
& S_IWRITE
|| (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2468 #else /* not MSDOS */
2469 #ifdef HAVE_EUIDACCESS
2470 return (euidaccess (filename
, 2) >= 0);
2472 /* Access isn't quite right because it uses the real uid
2473 and we really want to test with the effective uid.
2474 But Unix doesn't give us a right way to do it.
2475 Opening with O_WRONLY could work for an ordinary file,
2476 but would lose for directories. */
2477 return (access (filename
, 2) >= 0);
2479 #endif /* not MSDOS */
2482 DEFUN ("file-exists-p", Ffile_exists_p
, Sfile_exists_p
, 1, 1, 0,
2483 doc
: /* Return t if file FILENAME exists (whether or not you can read it.)
2484 See also `file-readable-p' and `file-attributes'.
2485 This returns nil for a symlink to a nonexistent file.
2486 Use `file-symlink-p' to test for such links. */)
2487 (Lisp_Object filename
)
2489 Lisp_Object absname
;
2490 Lisp_Object handler
;
2491 struct stat statbuf
;
2493 CHECK_STRING (filename
);
2494 absname
= Fexpand_file_name (filename
, Qnil
);
2496 /* If the file name has special constructs in it,
2497 call the corresponding file handler. */
2498 handler
= Ffind_file_name_handler (absname
, Qfile_exists_p
);
2499 if (!NILP (handler
))
2500 return call2 (handler
, Qfile_exists_p
, absname
);
2502 absname
= ENCODE_FILE (absname
);
2504 return (stat (SDATA (absname
), &statbuf
) >= 0) ? Qt
: Qnil
;
2507 DEFUN ("file-executable-p", Ffile_executable_p
, Sfile_executable_p
, 1, 1, 0,
2508 doc
: /* Return t if FILENAME can be executed by you.
2509 For a directory, this means you can access files in that directory. */)
2510 (Lisp_Object filename
)
2512 Lisp_Object absname
;
2513 Lisp_Object handler
;
2515 CHECK_STRING (filename
);
2516 absname
= Fexpand_file_name (filename
, Qnil
);
2518 /* If the file name has special constructs in it,
2519 call the corresponding file handler. */
2520 handler
= Ffind_file_name_handler (absname
, Qfile_executable_p
);
2521 if (!NILP (handler
))
2522 return call2 (handler
, Qfile_executable_p
, absname
);
2524 absname
= ENCODE_FILE (absname
);
2526 return (check_executable (SDATA (absname
)) ? Qt
: Qnil
);
2529 DEFUN ("file-readable-p", Ffile_readable_p
, Sfile_readable_p
, 1, 1, 0,
2530 doc
: /* Return t if file FILENAME exists and you can read it.
2531 See also `file-exists-p' and `file-attributes'. */)
2532 (Lisp_Object filename
)
2534 Lisp_Object absname
;
2535 Lisp_Object handler
;
2538 struct stat statbuf
;
2540 CHECK_STRING (filename
);
2541 absname
= Fexpand_file_name (filename
, Qnil
);
2543 /* If the file name has special constructs in it,
2544 call the corresponding file handler. */
2545 handler
= Ffind_file_name_handler (absname
, Qfile_readable_p
);
2546 if (!NILP (handler
))
2547 return call2 (handler
, Qfile_readable_p
, absname
);
2549 absname
= ENCODE_FILE (absname
);
2551 #if defined(DOS_NT) || defined(macintosh)
2552 /* Under MS-DOS, Windows, and Macintosh, open does not work for
2554 if (access (SDATA (absname
), 0) == 0)
2557 #else /* not DOS_NT and not macintosh */
2559 #if defined (S_ISFIFO) && defined (O_NONBLOCK)
2560 /* Opening a fifo without O_NONBLOCK can wait.
2561 We don't want to wait. But we don't want to mess wth O_NONBLOCK
2562 except in the case of a fifo, on a system which handles it. */
2563 desc
= stat (SDATA (absname
), &statbuf
);
2566 if (S_ISFIFO (statbuf
.st_mode
))
2567 flags
|= O_NONBLOCK
;
2569 desc
= emacs_open (SDATA (absname
), flags
, 0);
2574 #endif /* not DOS_NT and not macintosh */
2577 /* Having this before file-symlink-p mysteriously caused it to be forgotten
2579 DEFUN ("file-writable-p", Ffile_writable_p
, Sfile_writable_p
, 1, 1, 0,
2580 doc
: /* Return t if file FILENAME can be written or created by you. */)
2581 (Lisp_Object filename
)
2583 Lisp_Object absname
, dir
, encoded
;
2584 Lisp_Object handler
;
2585 struct stat statbuf
;
2587 CHECK_STRING (filename
);
2588 absname
= Fexpand_file_name (filename
, Qnil
);
2590 /* If the file name has special constructs in it,
2591 call the corresponding file handler. */
2592 handler
= Ffind_file_name_handler (absname
, Qfile_writable_p
);
2593 if (!NILP (handler
))
2594 return call2 (handler
, Qfile_writable_p
, absname
);
2596 encoded
= ENCODE_FILE (absname
);
2597 if (stat (SDATA (encoded
), &statbuf
) >= 0)
2598 return (check_writable (SDATA (encoded
))
2601 dir
= Ffile_name_directory (absname
);
2604 dir
= Fdirectory_file_name (dir
);
2607 dir
= ENCODE_FILE (dir
);
2609 /* The read-only attribute of the parent directory doesn't affect
2610 whether a file or directory can be created within it. Some day we
2611 should check ACLs though, which do affect this. */
2612 if (stat (SDATA (dir
), &statbuf
) < 0)
2614 return (statbuf
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
2616 return (check_writable (!NILP (dir
) ? (char *) SDATA (dir
) : "")
2621 DEFUN ("access-file", Faccess_file
, Saccess_file
, 2, 2, 0,
2622 doc
: /* Access file FILENAME, and get an error if that does not work.
2623 The second argument STRING is used in the error message.
2624 If there is no error, returns nil. */)
2625 (Lisp_Object filename
, Lisp_Object string
)
2627 Lisp_Object handler
, encoded_filename
, absname
;
2630 CHECK_STRING (filename
);
2631 absname
= Fexpand_file_name (filename
, Qnil
);
2633 CHECK_STRING (string
);
2635 /* If the file name has special constructs in it,
2636 call the corresponding file handler. */
2637 handler
= Ffind_file_name_handler (absname
, Qaccess_file
);
2638 if (!NILP (handler
))
2639 return call3 (handler
, Qaccess_file
, absname
, string
);
2641 encoded_filename
= ENCODE_FILE (absname
);
2643 fd
= emacs_open (SDATA (encoded_filename
), O_RDONLY
, 0);
2645 report_file_error (SDATA (string
), Fcons (filename
, Qnil
));
2651 DEFUN ("file-symlink-p", Ffile_symlink_p
, Sfile_symlink_p
, 1, 1, 0,
2652 doc
: /* Return non-nil if file FILENAME is the name of a symbolic link.
2653 The value is the link target, as a string.
2654 Otherwise it returns nil.
2656 This function returns t when given the name of a symlink that
2657 points to a nonexistent file. */)
2658 (Lisp_Object filename
)
2660 Lisp_Object handler
;
2662 CHECK_STRING (filename
);
2663 filename
= Fexpand_file_name (filename
, Qnil
);
2665 /* If the file name has special constructs in it,
2666 call the corresponding file handler. */
2667 handler
= Ffind_file_name_handler (filename
, Qfile_symlink_p
);
2668 if (!NILP (handler
))
2669 return call2 (handler
, Qfile_symlink_p
, filename
);
2678 filename
= ENCODE_FILE (filename
);
2685 buf
= (char *) xrealloc (buf
, bufsize
);
2686 memset (buf
, 0, bufsize
);
2689 valsize
= readlink (SDATA (filename
), buf
, bufsize
);
2693 /* HP-UX reports ERANGE if buffer is too small. */
2694 if (errno
== ERANGE
)
2704 while (valsize
>= bufsize
);
2706 val
= make_string (buf
, valsize
);
2707 if (buf
[0] == '/' && strchr (buf
, ':'))
2708 val
= concat2 (build_string ("/:"), val
);
2710 val
= DECODE_FILE (val
);
2713 #else /* not S_IFLNK */
2715 #endif /* not S_IFLNK */
2718 DEFUN ("file-directory-p", Ffile_directory_p
, Sfile_directory_p
, 1, 1, 0,
2719 doc
: /* Return t if FILENAME names an existing directory.
2720 Symbolic links to directories count as directories.
2721 See `file-symlink-p' to distinguish symlinks. */)
2722 (Lisp_Object filename
)
2724 register Lisp_Object absname
;
2726 Lisp_Object handler
;
2728 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2730 /* If the file name has special constructs in it,
2731 call the corresponding file handler. */
2732 handler
= Ffind_file_name_handler (absname
, Qfile_directory_p
);
2733 if (!NILP (handler
))
2734 return call2 (handler
, Qfile_directory_p
, absname
);
2736 absname
= ENCODE_FILE (absname
);
2738 if (stat (SDATA (absname
), &st
) < 0)
2740 return (st
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
2743 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p
, Sfile_accessible_directory_p
, 1, 1, 0,
2744 doc
: /* Return t if file FILENAME names a directory you can open.
2745 For the value to be t, FILENAME must specify the name of a directory as a file,
2746 and the directory must allow you to open files in it. In order to use a
2747 directory as a buffer's current directory, this predicate must return true.
2748 A directory name spec may be given instead; then the value is t
2749 if the directory so specified exists and really is a readable and
2750 searchable directory. */)
2751 (Lisp_Object filename
)
2753 Lisp_Object handler
;
2755 struct gcpro gcpro1
;
2757 /* If the file name has special constructs in it,
2758 call the corresponding file handler. */
2759 handler
= Ffind_file_name_handler (filename
, Qfile_accessible_directory_p
);
2760 if (!NILP (handler
))
2761 return call2 (handler
, Qfile_accessible_directory_p
, filename
);
2764 tem
= (NILP (Ffile_directory_p (filename
))
2765 || NILP (Ffile_executable_p (filename
)));
2767 return tem
? Qnil
: Qt
;
2770 DEFUN ("file-regular-p", Ffile_regular_p
, Sfile_regular_p
, 1, 1, 0,
2771 doc
: /* Return t if FILENAME names a regular file.
2772 This is the sort of file that holds an ordinary stream of data bytes.
2773 Symbolic links to regular files count as regular files.
2774 See `file-symlink-p' to distinguish symlinks. */)
2775 (Lisp_Object filename
)
2777 register Lisp_Object absname
;
2779 Lisp_Object handler
;
2781 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2783 /* If the file name has special constructs in it,
2784 call the corresponding file handler. */
2785 handler
= Ffind_file_name_handler (absname
, Qfile_regular_p
);
2786 if (!NILP (handler
))
2787 return call2 (handler
, Qfile_regular_p
, absname
);
2789 absname
= ENCODE_FILE (absname
);
2794 Lisp_Object tem
= Vw32_get_true_file_attributes
;
2796 /* Tell stat to use expensive method to get accurate info. */
2797 Vw32_get_true_file_attributes
= Qt
;
2798 result
= stat (SDATA (absname
), &st
);
2799 Vw32_get_true_file_attributes
= tem
;
2803 return (st
.st_mode
& S_IFMT
) == S_IFREG
? Qt
: Qnil
;
2806 if (stat (SDATA (absname
), &st
) < 0)
2808 return (st
.st_mode
& S_IFMT
) == S_IFREG
? Qt
: Qnil
;
2812 DEFUN ("file-selinux-context", Ffile_selinux_context
,
2813 Sfile_selinux_context
, 1, 1, 0,
2814 doc
: /* Return SELinux context of file named FILENAME,
2815 as a list ("user", "role", "type", "range"). Return (nil, nil, nil, nil)
2816 if file does not exist, is not accessible, or SELinux is disabled */)
2817 (Lisp_Object filename
)
2819 Lisp_Object absname
;
2820 Lisp_Object values
[4];
2821 Lisp_Object handler
;
2823 security_context_t con
;
2828 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2830 /* If the file name has special constructs in it,
2831 call the corresponding file handler. */
2832 handler
= Ffind_file_name_handler (absname
, Qfile_selinux_context
);
2833 if (!NILP (handler
))
2834 return call2 (handler
, Qfile_selinux_context
, absname
);
2836 absname
= ENCODE_FILE (absname
);
2843 if (is_selinux_enabled ())
2845 conlength
= lgetfilecon (SDATA (absname
), &con
);
2848 context
= context_new (con
);
2849 if (context_user_get (context
))
2850 values
[0] = build_string (context_user_get (context
));
2851 if (context_role_get (context
))
2852 values
[1] = build_string (context_role_get (context
));
2853 if (context_type_get (context
))
2854 values
[2] = build_string (context_type_get (context
));
2855 if (context_range_get (context
))
2856 values
[3] = build_string (context_range_get (context
));
2857 context_free (context
);
2864 return Flist (sizeof(values
) / sizeof(values
[0]), values
);
2867 DEFUN ("set-file-selinux-context", Fset_file_selinux_context
,
2868 Sset_file_selinux_context
, 2, 2, 0,
2869 doc
: /* Set SELinux context of file named FILENAME to CONTEXT
2870 as a list ("user", "role", "type", "range"). Has no effect if SELinux
2872 (Lisp_Object filename
, Lisp_Object context
)
2874 Lisp_Object absname
, encoded_absname
;
2875 Lisp_Object handler
;
2876 Lisp_Object user
= CAR_SAFE (context
);
2877 Lisp_Object role
= CAR_SAFE (CDR_SAFE (context
));
2878 Lisp_Object type
= CAR_SAFE (CDR_SAFE (CDR_SAFE (context
)));
2879 Lisp_Object range
= CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (context
))));
2881 security_context_t con
;
2882 int fail
, conlength
;
2883 context_t parsed_con
;
2886 absname
= Fexpand_file_name (filename
, current_buffer
->directory
);
2888 /* If the file name has special constructs in it,
2889 call the corresponding file handler. */
2890 handler
= Ffind_file_name_handler (absname
, Qset_file_selinux_context
);
2891 if (!NILP (handler
))
2892 return call3 (handler
, Qset_file_selinux_context
, absname
, context
);
2894 encoded_absname
= ENCODE_FILE (absname
);
2897 if (is_selinux_enabled ())
2899 /* Get current file context. */
2900 conlength
= lgetfilecon (SDATA (encoded_absname
), &con
);
2903 parsed_con
= context_new (con
);
2904 /* Change the parts defined in the parameter.*/
2907 if (context_user_set (parsed_con
, SDATA (user
)))
2908 error ("Doing context_user_set");
2912 if (context_role_set (parsed_con
, SDATA (role
)))
2913 error ("Doing context_role_set");
2917 if (context_type_set (parsed_con
, SDATA (type
)))
2918 error ("Doing context_type_set");
2920 if (STRINGP (range
))
2922 if (context_range_set (parsed_con
, SDATA (range
)))
2923 error ("Doing context_range_set");
2926 /* Set the modified context back to the file. */
2927 fail
= lsetfilecon (SDATA (encoded_absname
), context_str (parsed_con
));
2929 report_file_error ("Doing lsetfilecon", Fcons (absname
, Qnil
));
2931 context_free (parsed_con
);
2934 report_file_error("Doing lgetfilecon", Fcons (absname
, Qnil
));
2944 DEFUN ("file-modes", Ffile_modes
, Sfile_modes
, 1, 1, 0,
2945 doc
: /* Return mode bits of file named FILENAME, as an integer.
2946 Return nil, if file does not exist or is not accessible. */)
2947 (Lisp_Object filename
)
2949 Lisp_Object absname
;
2951 Lisp_Object handler
;
2953 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2955 /* If the file name has special constructs in it,
2956 call the corresponding file handler. */
2957 handler
= Ffind_file_name_handler (absname
, Qfile_modes
);
2958 if (!NILP (handler
))
2959 return call2 (handler
, Qfile_modes
, absname
);
2961 absname
= ENCODE_FILE (absname
);
2963 if (stat (SDATA (absname
), &st
) < 0)
2966 return make_number (st
.st_mode
& 07777);
2969 DEFUN ("set-file-modes", Fset_file_modes
, Sset_file_modes
, 2, 2,
2970 "(let ((file (read-file-name \"File: \"))) \
2971 (list file (read-file-modes nil file)))",
2972 doc
: /* Set mode bits of file named FILENAME to MODE (an integer).
2973 Only the 12 low bits of MODE are used.
2975 Interactively, mode bits are read by `read-file-modes', which accepts
2976 symbolic notation, like the `chmod' command from GNU Coreutils. */)
2977 (Lisp_Object filename
, Lisp_Object mode
)
2979 Lisp_Object absname
, encoded_absname
;
2980 Lisp_Object handler
;
2982 absname
= Fexpand_file_name (filename
, current_buffer
->directory
);
2983 CHECK_NUMBER (mode
);
2985 /* If the file name has special constructs in it,
2986 call the corresponding file handler. */
2987 handler
= Ffind_file_name_handler (absname
, Qset_file_modes
);
2988 if (!NILP (handler
))
2989 return call3 (handler
, Qset_file_modes
, absname
, mode
);
2991 encoded_absname
= ENCODE_FILE (absname
);
2993 if (chmod (SDATA (encoded_absname
), XINT (mode
)) < 0)
2994 report_file_error ("Doing chmod", Fcons (absname
, Qnil
));
2999 DEFUN ("set-default-file-modes", Fset_default_file_modes
, Sset_default_file_modes
, 1, 1, 0,
3000 doc
: /* Set the file permission bits for newly created files.
3001 The argument MODE should be an integer; only the low 9 bits are used.
3002 This setting is inherited by subprocesses. */)
3005 CHECK_NUMBER (mode
);
3007 umask ((~ XINT (mode
)) & 0777);
3012 DEFUN ("default-file-modes", Fdefault_file_modes
, Sdefault_file_modes
, 0, 0, 0,
3013 doc
: /* Return the default file protection for created files.
3014 The value is an integer. */)
3020 realmask
= umask (0);
3023 XSETINT (value
, (~ realmask
) & 0777);
3028 DEFUN ("set-file-times", Fset_file_times
, Sset_file_times
, 1, 2, 0,
3029 doc
: /* Set times of file FILENAME to TIME.
3030 Set both access and modification times.
3031 Return t on success, else nil.
3032 Use the current time if TIME is nil. TIME is in the format of
3034 (Lisp_Object filename
, Lisp_Object time
)
3036 Lisp_Object absname
, encoded_absname
;
3037 Lisp_Object handler
;
3041 if (! lisp_time_argument (time
, &sec
, &usec
))
3042 error ("Invalid time specification");
3044 absname
= Fexpand_file_name (filename
, current_buffer
->directory
);
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_times
);
3049 if (!NILP (handler
))
3050 return call3 (handler
, Qset_file_times
, absname
, time
);
3052 encoded_absname
= ENCODE_FILE (absname
);
3057 EMACS_SET_SECS (t
, sec
);
3058 EMACS_SET_USECS (t
, usec
);
3060 if (set_file_times (SDATA (encoded_absname
), t
, t
))
3065 /* Setting times on a directory always fails. */
3066 if (stat (SDATA (encoded_absname
), &st
) == 0
3067 && (st
.st_mode
& S_IFMT
) == S_IFDIR
)
3070 report_file_error ("Setting file times", Fcons (absname
, Qnil
));
3079 DEFUN ("unix-sync", Funix_sync
, Sunix_sync
, 0, 0, "",
3080 doc
: /* Tell Unix to finish all pending disk updates. */)
3087 #endif /* HAVE_SYNC */
3089 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p
, Sfile_newer_than_file_p
, 2, 2, 0,
3090 doc
: /* Return t if file FILE1 is newer than file FILE2.
3091 If FILE1 does not exist, the answer is nil;
3092 otherwise, if FILE2 does not exist, the answer is t. */)
3093 (Lisp_Object file1
, Lisp_Object file2
)
3095 Lisp_Object absname1
, absname2
;
3098 Lisp_Object handler
;
3099 struct gcpro gcpro1
, gcpro2
;
3101 CHECK_STRING (file1
);
3102 CHECK_STRING (file2
);
3105 GCPRO2 (absname1
, file2
);
3106 absname1
= expand_and_dir_to_file (file1
, current_buffer
->directory
);
3107 absname2
= expand_and_dir_to_file (file2
, current_buffer
->directory
);
3110 /* If the file name has special constructs in it,
3111 call the corresponding file handler. */
3112 handler
= Ffind_file_name_handler (absname1
, Qfile_newer_than_file_p
);
3114 handler
= Ffind_file_name_handler (absname2
, Qfile_newer_than_file_p
);
3115 if (!NILP (handler
))
3116 return call3 (handler
, Qfile_newer_than_file_p
, absname1
, absname2
);
3118 GCPRO2 (absname1
, absname2
);
3119 absname1
= ENCODE_FILE (absname1
);
3120 absname2
= ENCODE_FILE (absname2
);
3123 if (stat (SDATA (absname1
), &st
) < 0)
3126 mtime1
= st
.st_mtime
;
3128 if (stat (SDATA (absname2
), &st
) < 0)
3131 return (mtime1
> st
.st_mtime
) ? Qt
: Qnil
;
3135 Lisp_Object Qfind_buffer_file_type
;
3138 #ifndef READ_BUF_SIZE
3139 #define READ_BUF_SIZE (64 << 10)
3142 /* This function is called after Lisp functions to decide a coding
3143 system are called, or when they cause an error. Before they are
3144 called, the current buffer is set unibyte and it contains only a
3145 newly inserted text (thus the buffer was empty before the
3148 The functions may set markers, overlays, text properties, or even
3149 alter the buffer contents, change the current buffer.
3151 Here, we reset all those changes by:
3152 o set back the current buffer.
3153 o move all markers and overlays to BEG.
3154 o remove all text properties.
3155 o set back the buffer multibyteness. */
3158 decide_coding_unwind (Lisp_Object unwind_data
)
3160 Lisp_Object multibyte
, undo_list
, buffer
;
3162 multibyte
= XCAR (unwind_data
);
3163 unwind_data
= XCDR (unwind_data
);
3164 undo_list
= XCAR (unwind_data
);
3165 buffer
= XCDR (unwind_data
);
3167 if (current_buffer
!= XBUFFER (buffer
))
3168 set_buffer_internal (XBUFFER (buffer
));
3169 adjust_markers_for_delete (BEG
, BEG_BYTE
, Z
, Z_BYTE
);
3170 adjust_overlays_for_delete (BEG
, Z
- BEG
);
3171 BUF_INTERVALS (current_buffer
) = 0;
3172 TEMP_SET_PT_BOTH (BEG
, BEG_BYTE
);
3174 /* Now we are safe to change the buffer's multibyteness directly. */
3175 current_buffer
->enable_multibyte_characters
= multibyte
;
3176 current_buffer
->undo_list
= undo_list
;
3182 /* Used to pass values from insert-file-contents to read_non_regular. */
3184 static int non_regular_fd
;
3185 static EMACS_INT non_regular_inserted
;
3186 static EMACS_INT non_regular_nbytes
;
3189 /* Read from a non-regular file.
3190 Read non_regular_nbytes bytes max from non_regular_fd.
3191 Non_regular_inserted specifies where to put the read bytes.
3192 Value is the number of bytes read. */
3195 read_non_regular (Lisp_Object ignore
)
3201 nbytes
= emacs_read (non_regular_fd
,
3202 BEG_ADDR
+ PT_BYTE
- BEG_BYTE
+ non_regular_inserted
,
3203 non_regular_nbytes
);
3205 return make_number (nbytes
);
3209 /* Condition-case handler used when reading from non-regular files
3210 in insert-file-contents. */
3213 read_non_regular_quit (Lisp_Object ignore
)
3219 DEFUN ("insert-file-contents", Finsert_file_contents
, Sinsert_file_contents
,
3221 doc
: /* Insert contents of file FILENAME after point.
3222 Returns list of absolute file name and number of characters inserted.
3223 If second argument VISIT is non-nil, the buffer's visited filename and
3224 last save file modtime are set, and it is marked unmodified. If
3225 visiting and the file does not exist, visiting is completed before the
3228 The optional third and fourth arguments BEG and END specify what portion
3229 of the file to insert. These arguments count bytes in the file, not
3230 characters in the buffer. If VISIT is non-nil, BEG and END must be nil.
3232 If optional fifth argument REPLACE is non-nil, replace the current
3233 buffer contents (in the accessible portion) with the file contents.
3234 This is better than simply deleting and inserting the whole thing
3235 because (1) it preserves some marker positions and (2) it puts less data
3236 in the undo list. When REPLACE is non-nil, the second return value is
3237 the number of characters that replace previous buffer contents.
3239 This function does code conversion according to the value of
3240 `coding-system-for-read' or `file-coding-system-alist', and sets the
3241 variable `last-coding-system-used' to the coding system actually used. */)
3242 (Lisp_Object filename
, Lisp_Object visit
, Lisp_Object beg
, Lisp_Object end
, Lisp_Object replace
)
3246 EMACS_INT inserted
= 0;
3248 register EMACS_INT how_much
;
3249 register EMACS_INT unprocessed
;
3250 int count
= SPECPDL_INDEX ();
3251 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
3252 Lisp_Object handler
, val
, insval
, orig_filename
, old_undo
;
3254 EMACS_INT total
= 0;
3255 int not_regular
= 0;
3256 unsigned char read_buf
[READ_BUF_SIZE
];
3257 struct coding_system coding
;
3258 unsigned char buffer
[1 << 14];
3259 int replace_handled
= 0;
3260 int set_coding_system
= 0;
3261 Lisp_Object coding_system
;
3263 Lisp_Object old_Vdeactivate_mark
= Vdeactivate_mark
;
3264 int we_locked_file
= 0;
3265 int deferred_remove_unwind_protect
= 0;
3267 if (current_buffer
->base_buffer
&& ! NILP (visit
))
3268 error ("Cannot do file visiting in an indirect buffer");
3270 if (!NILP (current_buffer
->read_only
))
3271 Fbarf_if_buffer_read_only ();
3275 orig_filename
= Qnil
;
3278 GCPRO5 (filename
, val
, p
, orig_filename
, old_undo
);
3280 CHECK_STRING (filename
);
3281 filename
= Fexpand_file_name (filename
, Qnil
);
3283 /* The value Qnil means that the coding system is not yet
3285 coding_system
= Qnil
;
3287 /* If the file name has special constructs in it,
3288 call the corresponding file handler. */
3289 handler
= Ffind_file_name_handler (filename
, Qinsert_file_contents
);
3290 if (!NILP (handler
))
3292 val
= call6 (handler
, Qinsert_file_contents
, filename
,
3293 visit
, beg
, end
, replace
);
3294 if (CONSP (val
) && CONSP (XCDR (val
)))
3295 inserted
= XINT (XCAR (XCDR (val
)));
3299 orig_filename
= filename
;
3300 filename
= ENCODE_FILE (filename
);
3306 Lisp_Object tem
= Vw32_get_true_file_attributes
;
3308 /* Tell stat to use expensive method to get accurate info. */
3309 Vw32_get_true_file_attributes
= Qt
;
3310 total
= stat (SDATA (filename
), &st
);
3311 Vw32_get_true_file_attributes
= tem
;
3315 if (stat (SDATA (filename
), &st
) < 0)
3316 #endif /* WINDOWSNT */
3318 if (fd
>= 0) emacs_close (fd
);
3321 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
3324 if (!NILP (Vcoding_system_for_read
))
3325 Fset (Qbuffer_file_coding_system
, Vcoding_system_for_read
);
3330 /* This code will need to be changed in order to work on named
3331 pipes, and it's probably just not worth it. So we should at
3332 least signal an error. */
3333 if (!S_ISREG (st
.st_mode
))
3340 if (! NILP (replace
) || ! NILP (beg
) || ! NILP (end
))
3341 xsignal2 (Qfile_error
,
3342 build_string ("not a regular file"), orig_filename
);
3347 if ((fd
= emacs_open (SDATA (filename
), O_RDONLY
, 0)) < 0)
3350 /* Replacement should preserve point as it preserves markers. */
3351 if (!NILP (replace
))
3352 record_unwind_protect (restore_point_unwind
, Fpoint_marker ());
3354 record_unwind_protect (close_file_unwind
, make_number (fd
));
3356 /* Can happen on any platform that uses long as type of off_t, but allows
3357 file sizes to exceed 2Gb, so give a suitable message. */
3358 if (! not_regular
&& st
.st_size
< 0)
3359 error ("Maximum buffer size exceeded");
3361 /* Prevent redisplay optimizations. */
3362 current_buffer
->clip_changed
= 1;
3366 if (!NILP (beg
) || !NILP (end
))
3367 error ("Attempt to visit less than an entire file");
3368 if (BEG
< Z
&& NILP (replace
))
3369 error ("Cannot do file visiting in a non-empty buffer");
3375 XSETFASTINT (beg
, 0);
3383 XSETINT (end
, st
.st_size
);
3385 /* Arithmetic overflow can occur if an Emacs integer cannot
3386 represent the file size, or if the calculations below
3387 overflow. The calculations below double the file size
3388 twice, so check that it can be multiplied by 4 safely. */
3389 if (XINT (end
) != st
.st_size
3390 /* Actually, it should test either INT_MAX or LONG_MAX
3391 depending on which one is used for EMACS_INT. But in
3392 any case, in practice, this test is redundant with the
3394 || st.st_size > INT_MAX / 4 */)
3395 error ("Maximum buffer size exceeded");
3397 /* The file size returned from stat may be zero, but data
3398 may be readable nonetheless, for example when this is a
3399 file in the /proc filesystem. */
3400 if (st
.st_size
== 0)
3401 XSETINT (end
, READ_BUF_SIZE
);
3405 if (EQ (Vcoding_system_for_read
, Qauto_save_coding
))
3407 coding_system
= coding_inherit_eol_type (Qutf_8_emacs
, Qunix
);
3408 setup_coding_system (coding_system
, &coding
);
3409 /* Ensure we set Vlast_coding_system_used. */
3410 set_coding_system
= 1;
3414 /* Decide the coding system to use for reading the file now
3415 because we can't use an optimized method for handling
3416 `coding:' tag if the current buffer is not empty. */
3417 if (!NILP (Vcoding_system_for_read
))
3418 coding_system
= Vcoding_system_for_read
;
3421 /* Don't try looking inside a file for a coding system
3422 specification if it is not seekable. */
3423 if (! not_regular
&& ! NILP (Vset_auto_coding_function
))
3425 /* Find a coding system specified in the heading two
3426 lines or in the tailing several lines of the file.
3427 We assume that the 1K-byte and 3K-byte for heading
3428 and tailing respectively are sufficient for this
3432 if (st
.st_size
<= (1024 * 4))
3433 nread
= emacs_read (fd
, read_buf
, 1024 * 4);
3436 nread
= emacs_read (fd
, read_buf
, 1024);
3439 if (lseek (fd
, st
.st_size
- (1024 * 3), 0) < 0)
3440 report_file_error ("Setting file position",
3441 Fcons (orig_filename
, Qnil
));
3442 nread
+= emacs_read (fd
, read_buf
+ nread
, 1024 * 3);
3447 error ("IO error reading %s: %s",
3448 SDATA (orig_filename
), emacs_strerror (errno
));
3451 struct buffer
*prev
= current_buffer
;
3455 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
3457 buffer
= Fget_buffer_create (build_string (" *code-converting-work*"));
3458 buf
= XBUFFER (buffer
);
3460 delete_all_overlays (buf
);
3461 buf
->directory
= current_buffer
->directory
;
3462 buf
->read_only
= Qnil
;
3463 buf
->filename
= Qnil
;
3464 buf
->undo_list
= Qt
;
3465 eassert (buf
->overlays_before
== NULL
);
3466 eassert (buf
->overlays_after
== NULL
);
3468 set_buffer_internal (buf
);
3470 buf
->enable_multibyte_characters
= Qnil
;
3472 insert_1_both (read_buf
, nread
, nread
, 0, 0, 0);
3473 TEMP_SET_PT_BOTH (BEG
, BEG_BYTE
);
3474 coding_system
= call2 (Vset_auto_coding_function
,
3475 filename
, make_number (nread
));
3476 set_buffer_internal (prev
);
3478 /* Discard the unwind protect for recovering the
3482 /* Rewind the file for the actual read done later. */
3483 if (lseek (fd
, 0, 0) < 0)
3484 report_file_error ("Setting file position",
3485 Fcons (orig_filename
, Qnil
));
3489 if (NILP (coding_system
))
3491 /* If we have not yet decided a coding system, check
3492 file-coding-system-alist. */
3493 Lisp_Object args
[6];
3495 args
[0] = Qinsert_file_contents
, args
[1] = orig_filename
;
3496 args
[2] = visit
, args
[3] = beg
, args
[4] = end
, args
[5] = replace
;
3497 coding_system
= Ffind_operation_coding_system (6, args
);
3498 if (CONSP (coding_system
))
3499 coding_system
= XCAR (coding_system
);
3503 if (NILP (coding_system
))
3504 coding_system
= Qundecided
;
3506 CHECK_CODING_SYSTEM (coding_system
);
3508 if (NILP (current_buffer
->enable_multibyte_characters
))
3509 /* We must suppress all character code conversion except for
3510 end-of-line conversion. */
3511 coding_system
= raw_text_coding_system (coding_system
);
3513 setup_coding_system (coding_system
, &coding
);
3514 /* Ensure we set Vlast_coding_system_used. */
3515 set_coding_system
= 1;
3518 /* If requested, replace the accessible part of the buffer
3519 with the file contents. Avoid replacing text at the
3520 beginning or end of the buffer that matches the file contents;
3521 that preserves markers pointing to the unchanged parts.
3523 Here we implement this feature in an optimized way
3524 for the case where code conversion is NOT needed.
3525 The following if-statement handles the case of conversion
3526 in a less optimal way.
3528 If the code conversion is "automatic" then we try using this
3529 method and hope for the best.
3530 But if we discover the need for conversion, we give up on this method
3531 and let the following if-statement handle the replace job. */
3534 && (NILP (coding_system
)
3535 || ! CODING_REQUIRE_DECODING (&coding
)))
3537 /* same_at_start and same_at_end count bytes,
3538 because file access counts bytes
3539 and BEG and END count bytes. */
3540 EMACS_INT same_at_start
= BEGV_BYTE
;
3541 EMACS_INT same_at_end
= ZV_BYTE
;
3543 /* There is still a possibility we will find the need to do code
3544 conversion. If that happens, we set this variable to 1 to
3545 give up on handling REPLACE in the optimized way. */
3546 int giveup_match_end
= 0;
3548 if (XINT (beg
) != 0)
3550 if (lseek (fd
, XINT (beg
), 0) < 0)
3551 report_file_error ("Setting file position",
3552 Fcons (orig_filename
, Qnil
));
3557 /* Count how many chars at the start of the file
3558 match the text at the beginning of the buffer. */
3561 EMACS_INT nread
, bufpos
;
3563 nread
= emacs_read (fd
, buffer
, sizeof buffer
);
3565 error ("IO error reading %s: %s",
3566 SDATA (orig_filename
), emacs_strerror (errno
));
3567 else if (nread
== 0)
3570 if (CODING_REQUIRE_DETECTION (&coding
))
3572 coding_system
= detect_coding_system (buffer
, nread
, nread
, 1, 0,
3574 setup_coding_system (coding_system
, &coding
);
3577 if (CODING_REQUIRE_DECODING (&coding
))
3578 /* We found that the file should be decoded somehow.
3579 Let's give up here. */
3581 giveup_match_end
= 1;
3586 while (bufpos
< nread
&& same_at_start
< ZV_BYTE
3587 && FETCH_BYTE (same_at_start
) == buffer
[bufpos
])
3588 same_at_start
++, bufpos
++;
3589 /* If we found a discrepancy, stop the scan.
3590 Otherwise loop around and scan the next bufferful. */
3591 if (bufpos
!= nread
)
3595 /* If the file matches the buffer completely,
3596 there's no need to replace anything. */
3597 if (same_at_start
- BEGV_BYTE
== XINT (end
))
3601 /* Truncate the buffer to the size of the file. */
3602 del_range_1 (same_at_start
, same_at_end
, 0, 0);
3607 /* Count how many chars at the end of the file
3608 match the text at the end of the buffer. But, if we have
3609 already found that decoding is necessary, don't waste time. */
3610 while (!giveup_match_end
)
3612 EMACS_INT total_read
, nread
, bufpos
, curpos
, trial
;
3614 /* At what file position are we now scanning? */
3615 curpos
= XINT (end
) - (ZV_BYTE
- same_at_end
);
3616 /* If the entire file matches the buffer tail, stop the scan. */
3619 /* How much can we scan in the next step? */
3620 trial
= min (curpos
, sizeof buffer
);
3621 if (lseek (fd
, curpos
- trial
, 0) < 0)
3622 report_file_error ("Setting file position",
3623 Fcons (orig_filename
, Qnil
));
3625 total_read
= nread
= 0;
3626 while (total_read
< trial
)
3628 nread
= emacs_read (fd
, buffer
+ total_read
, trial
- total_read
);
3630 error ("IO error reading %s: %s",
3631 SDATA (orig_filename
), emacs_strerror (errno
));
3632 else if (nread
== 0)
3634 total_read
+= nread
;
3637 /* Scan this bufferful from the end, comparing with
3638 the Emacs buffer. */
3639 bufpos
= total_read
;
3641 /* Compare with same_at_start to avoid counting some buffer text
3642 as matching both at the file's beginning and at the end. */
3643 while (bufpos
> 0 && same_at_end
> same_at_start
3644 && FETCH_BYTE (same_at_end
- 1) == buffer
[bufpos
- 1])
3645 same_at_end
--, bufpos
--;
3647 /* If we found a discrepancy, stop the scan.
3648 Otherwise loop around and scan the preceding bufferful. */
3651 /* If this discrepancy is because of code conversion,
3652 we cannot use this method; giveup and try the other. */
3653 if (same_at_end
> same_at_start
3654 && FETCH_BYTE (same_at_end
- 1) >= 0200
3655 && ! NILP (current_buffer
->enable_multibyte_characters
)
3656 && (CODING_MAY_REQUIRE_DECODING (&coding
)))
3657 giveup_match_end
= 1;
3666 if (! giveup_match_end
)
3670 /* We win! We can handle REPLACE the optimized way. */
3672 /* Extend the start of non-matching text area to multibyte
3673 character boundary. */
3674 if (! NILP (current_buffer
->enable_multibyte_characters
))
3675 while (same_at_start
> BEGV_BYTE
3676 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_start
)))
3679 /* Extend the end of non-matching text area to multibyte
3680 character boundary. */
3681 if (! NILP (current_buffer
->enable_multibyte_characters
))
3682 while (same_at_end
< ZV_BYTE
3683 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_end
)))
3686 /* Don't try to reuse the same piece of text twice. */
3687 overlap
= (same_at_start
- BEGV_BYTE
3688 - (same_at_end
+ st
.st_size
- ZV
));
3690 same_at_end
+= overlap
;
3692 /* Arrange to read only the nonmatching middle part of the file. */
3693 XSETFASTINT (beg
, XINT (beg
) + (same_at_start
- BEGV_BYTE
));
3694 XSETFASTINT (end
, XINT (end
) - (ZV_BYTE
- same_at_end
));
3696 del_range_byte (same_at_start
, same_at_end
, 0);
3697 /* Insert from the file at the proper position. */
3698 temp
= BYTE_TO_CHAR (same_at_start
);
3699 SET_PT_BOTH (temp
, same_at_start
);
3701 /* If display currently starts at beginning of line,
3702 keep it that way. */
3703 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3704 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3706 replace_handled
= 1;
3710 /* If requested, replace the accessible part of the buffer
3711 with the file contents. Avoid replacing text at the
3712 beginning or end of the buffer that matches the file contents;
3713 that preserves markers pointing to the unchanged parts.
3715 Here we implement this feature for the case where code conversion
3716 is needed, in a simple way that needs a lot of memory.
3717 The preceding if-statement handles the case of no conversion
3718 in a more optimized way. */
3719 if (!NILP (replace
) && ! replace_handled
&& BEGV
< ZV
)
3721 EMACS_INT same_at_start
= BEGV_BYTE
;
3722 EMACS_INT same_at_end
= ZV_BYTE
;
3723 EMACS_INT same_at_start_charpos
;
3724 EMACS_INT inserted_chars
;
3727 unsigned char *decoded
;
3729 int this_count
= SPECPDL_INDEX ();
3730 int multibyte
= ! NILP (current_buffer
->enable_multibyte_characters
);
3731 Lisp_Object conversion_buffer
;
3733 conversion_buffer
= code_conversion_save (1, multibyte
);
3735 /* First read the whole file, performing code conversion into
3736 CONVERSION_BUFFER. */
3738 if (lseek (fd
, XINT (beg
), 0) < 0)
3739 report_file_error ("Setting file position",
3740 Fcons (orig_filename
, Qnil
));
3742 total
= st
.st_size
; /* Total bytes in the file. */
3743 how_much
= 0; /* Bytes read from file so far. */
3744 inserted
= 0; /* Bytes put into CONVERSION_BUFFER so far. */
3745 unprocessed
= 0; /* Bytes not processed in previous loop. */
3747 GCPRO1 (conversion_buffer
);
3748 while (how_much
< total
)
3750 /* We read one bunch by one (READ_BUF_SIZE bytes) to allow
3751 quitting while reading a huge while. */
3752 /* try is reserved in some compilers (Microsoft C) */
3753 EMACS_INT trytry
= min (total
- how_much
,
3754 READ_BUF_SIZE
- unprocessed
);
3757 /* Allow quitting out of the actual I/O. */
3760 this = emacs_read (fd
, read_buf
+ unprocessed
, trytry
);
3772 BUF_TEMP_SET_PT (XBUFFER (conversion_buffer
),
3773 BUF_Z (XBUFFER (conversion_buffer
)));
3774 decode_coding_c_string (&coding
, read_buf
, unprocessed
+ this,
3776 unprocessed
= coding
.carryover_bytes
;
3777 if (coding
.carryover_bytes
> 0)
3778 memcpy (read_buf
, coding
.carryover
, unprocessed
);
3783 /* We should remove the unwind_protect calling
3784 close_file_unwind, but other stuff has been added the stack,
3785 so defer the removal till we reach the `handled' label. */
3786 deferred_remove_unwind_protect
= 1;
3788 /* At this point, HOW_MUCH should equal TOTAL, or should be <= 0
3789 if we couldn't read the file. */
3792 error ("IO error reading %s: %s",
3793 SDATA (orig_filename
), emacs_strerror (errno
));
3795 if (unprocessed
> 0)
3797 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
3798 decode_coding_c_string (&coding
, read_buf
, unprocessed
,
3800 coding
.mode
&= ~CODING_MODE_LAST_BLOCK
;
3803 coding_system
= CODING_ID_NAME (coding
.id
);
3804 set_coding_system
= 1;
3805 decoded
= BUF_BEG_ADDR (XBUFFER (conversion_buffer
));
3806 inserted
= (BUF_Z_BYTE (XBUFFER (conversion_buffer
))
3807 - BUF_BEG_BYTE (XBUFFER (conversion_buffer
)));
3809 /* Compare the beginning of the converted string with the buffer
3813 while (bufpos
< inserted
&& same_at_start
< same_at_end
3814 && FETCH_BYTE (same_at_start
) == decoded
[bufpos
])
3815 same_at_start
++, bufpos
++;
3817 /* If the file matches the head of buffer completely,
3818 there's no need to replace anything. */
3820 if (bufpos
== inserted
)
3822 /* Truncate the buffer to the size of the file. */
3823 if (same_at_start
== same_at_end
)
3826 del_range_byte (same_at_start
, same_at_end
, 0);
3829 unbind_to (this_count
, Qnil
);
3833 /* Extend the start of non-matching text area to the previous
3834 multibyte character boundary. */
3835 if (! NILP (current_buffer
->enable_multibyte_characters
))
3836 while (same_at_start
> BEGV_BYTE
3837 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_start
)))
3840 /* Scan this bufferful from the end, comparing with
3841 the Emacs buffer. */
3844 /* Compare with same_at_start to avoid counting some buffer text
3845 as matching both at the file's beginning and at the end. */
3846 while (bufpos
> 0 && same_at_end
> same_at_start
3847 && FETCH_BYTE (same_at_end
- 1) == decoded
[bufpos
- 1])
3848 same_at_end
--, bufpos
--;
3850 /* Extend the end of non-matching text area to the next
3851 multibyte character boundary. */
3852 if (! NILP (current_buffer
->enable_multibyte_characters
))
3853 while (same_at_end
< ZV_BYTE
3854 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_end
)))
3857 /* Don't try to reuse the same piece of text twice. */
3858 overlap
= same_at_start
- BEGV_BYTE
- (same_at_end
+ inserted
- ZV_BYTE
);
3860 same_at_end
+= overlap
;
3862 /* If display currently starts at beginning of line,
3863 keep it that way. */
3864 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3865 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3867 /* Replace the chars that we need to replace,
3868 and update INSERTED to equal the number of bytes
3869 we are taking from the decoded string. */
3870 inserted
-= (ZV_BYTE
- same_at_end
) + (same_at_start
- BEGV_BYTE
);
3872 if (same_at_end
!= same_at_start
)
3874 del_range_byte (same_at_start
, same_at_end
, 0);
3876 same_at_start
= GPT_BYTE
;
3880 temp
= BYTE_TO_CHAR (same_at_start
);
3882 /* Insert from the file at the proper position. */
3883 SET_PT_BOTH (temp
, same_at_start
);
3884 same_at_start_charpos
3885 = buf_bytepos_to_charpos (XBUFFER (conversion_buffer
),
3886 same_at_start
- BEGV_BYTE
3887 + BUF_BEG_BYTE (XBUFFER (conversion_buffer
)));
3889 = (buf_bytepos_to_charpos (XBUFFER (conversion_buffer
),
3890 same_at_start
+ inserted
- BEGV_BYTE
3891 + BUF_BEG_BYTE (XBUFFER (conversion_buffer
)))
3892 - same_at_start_charpos
);
3893 /* This binding is to avoid ask-user-about-supersession-threat
3894 being called in insert_from_buffer (via in
3895 prepare_to_modify_buffer). */
3896 specbind (intern ("buffer-file-name"), Qnil
);
3897 insert_from_buffer (XBUFFER (conversion_buffer
),
3898 same_at_start_charpos
, inserted_chars
, 0);
3899 /* Set `inserted' to the number of inserted characters. */
3900 inserted
= PT
- temp
;
3901 /* Set point before the inserted characters. */
3902 SET_PT_BOTH (temp
, same_at_start
);
3904 unbind_to (this_count
, Qnil
);
3911 register Lisp_Object temp
;
3913 total
= XINT (end
) - XINT (beg
);
3915 /* Make sure point-max won't overflow after this insertion. */
3916 XSETINT (temp
, total
);
3917 if (total
!= XINT (temp
))
3918 error ("Maximum buffer size exceeded");
3921 /* For a special file, all we can do is guess. */
3922 total
= READ_BUF_SIZE
;
3924 if (NILP (visit
) && inserted
> 0)
3926 #ifdef CLASH_DETECTION
3927 if (!NILP (current_buffer
->file_truename
)
3928 /* Make binding buffer-file-name to nil effective. */
3929 && !NILP (current_buffer
->filename
)
3930 && SAVE_MODIFF
>= MODIFF
)
3932 #endif /* CLASH_DETECTION */
3933 prepare_to_modify_buffer (GPT
, GPT
, NULL
);
3937 if (GAP_SIZE
< total
)
3938 make_gap (total
- GAP_SIZE
);
3940 if (XINT (beg
) != 0 || !NILP (replace
))
3942 if (lseek (fd
, XINT (beg
), 0) < 0)
3943 report_file_error ("Setting file position",
3944 Fcons (orig_filename
, Qnil
));
3947 /* In the following loop, HOW_MUCH contains the total bytes read so
3948 far for a regular file, and not changed for a special file. But,
3949 before exiting the loop, it is set to a negative value if I/O
3953 /* Total bytes inserted. */
3956 /* Here, we don't do code conversion in the loop. It is done by
3957 decode_coding_gap after all data are read into the buffer. */
3959 EMACS_INT gap_size
= GAP_SIZE
;
3961 while (how_much
< total
)
3963 /* try is reserved in some compilers (Microsoft C) */
3964 EMACS_INT trytry
= min (total
- how_much
, READ_BUF_SIZE
);
3971 /* Maybe make more room. */
3972 if (gap_size
< trytry
)
3974 make_gap (total
- gap_size
);
3975 gap_size
= GAP_SIZE
;
3978 /* Read from the file, capturing `quit'. When an
3979 error occurs, end the loop, and arrange for a quit
3980 to be signaled after decoding the text we read. */
3981 non_regular_fd
= fd
;
3982 non_regular_inserted
= inserted
;
3983 non_regular_nbytes
= trytry
;
3984 val
= internal_condition_case_1 (read_non_regular
, Qnil
, Qerror
,
3985 read_non_regular_quit
);
3996 /* Allow quitting out of the actual I/O. We don't make text
3997 part of the buffer until all the reading is done, so a C-g
3998 here doesn't do any harm. */
4001 this = emacs_read (fd
, BEG_ADDR
+ PT_BYTE
- BEG_BYTE
+ inserted
, trytry
);
4013 /* For a regular file, where TOTAL is the real size,
4014 count HOW_MUCH to compare with it.
4015 For a special file, where TOTAL is just a buffer size,
4016 so don't bother counting in HOW_MUCH.
4017 (INSERTED is where we count the number of characters inserted.) */
4024 /* Now we have read all the file data into the gap.
4025 If it was empty, undo marking the buffer modified. */
4029 #ifdef CLASH_DETECTION
4031 unlock_file (current_buffer
->file_truename
);
4033 Vdeactivate_mark
= old_Vdeactivate_mark
;
4036 Vdeactivate_mark
= Qt
;
4038 /* Make the text read part of the buffer. */
4039 GAP_SIZE
-= inserted
;
4041 GPT_BYTE
+= inserted
;
4043 ZV_BYTE
+= inserted
;
4048 /* Put an anchor to ensure multi-byte form ends at gap. */
4053 /* Discard the unwind protect for closing the file. */
4057 error ("IO error reading %s: %s",
4058 SDATA (orig_filename
), emacs_strerror (errno
));
4062 if (NILP (coding_system
))
4064 /* The coding system is not yet decided. Decide it by an
4065 optimized method for handling `coding:' tag.
4067 Note that we can get here only if the buffer was empty
4068 before the insertion. */
4070 if (!NILP (Vcoding_system_for_read
))
4071 coding_system
= Vcoding_system_for_read
;
4074 /* Since we are sure that the current buffer was empty
4075 before the insertion, we can toggle
4076 enable-multibyte-characters directly here without taking
4077 care of marker adjustment. By this way, we can run Lisp
4078 program safely before decoding the inserted text. */
4079 Lisp_Object unwind_data
;
4080 int count
= SPECPDL_INDEX ();
4082 unwind_data
= Fcons (current_buffer
->enable_multibyte_characters
,
4083 Fcons (current_buffer
->undo_list
,
4084 Fcurrent_buffer ()));
4085 current_buffer
->enable_multibyte_characters
= Qnil
;
4086 current_buffer
->undo_list
= Qt
;
4087 record_unwind_protect (decide_coding_unwind
, unwind_data
);
4089 if (inserted
> 0 && ! NILP (Vset_auto_coding_function
))
4091 coding_system
= call2 (Vset_auto_coding_function
,
4092 filename
, make_number (inserted
));
4095 if (NILP (coding_system
))
4097 /* If the coding system is not yet decided, check
4098 file-coding-system-alist. */
4099 Lisp_Object args
[6];
4101 args
[0] = Qinsert_file_contents
, args
[1] = orig_filename
;
4102 args
[2] = visit
, args
[3] = beg
, args
[4] = end
, args
[5] = Qnil
;
4103 coding_system
= Ffind_operation_coding_system (6, args
);
4104 if (CONSP (coding_system
))
4105 coding_system
= XCAR (coding_system
);
4107 unbind_to (count
, Qnil
);
4108 inserted
= Z_BYTE
- BEG_BYTE
;
4111 if (NILP (coding_system
))
4112 coding_system
= Qundecided
;
4114 CHECK_CODING_SYSTEM (coding_system
);
4116 if (NILP (current_buffer
->enable_multibyte_characters
))
4117 /* We must suppress all character code conversion except for
4118 end-of-line conversion. */
4119 coding_system
= raw_text_coding_system (coding_system
);
4120 setup_coding_system (coding_system
, &coding
);
4121 /* Ensure we set Vlast_coding_system_used. */
4122 set_coding_system
= 1;
4127 /* When we visit a file by raw-text, we change the buffer to
4129 if (CODING_FOR_UNIBYTE (&coding
)
4130 /* Can't do this if part of the buffer might be preserved. */
4132 /* Visiting a file with these coding system makes the buffer
4134 current_buffer
->enable_multibyte_characters
= Qnil
;
4137 coding
.dst_multibyte
= ! NILP (current_buffer
->enable_multibyte_characters
);
4138 if (CODING_MAY_REQUIRE_DECODING (&coding
)
4139 && (inserted
> 0 || CODING_REQUIRE_FLUSHING (&coding
)))
4141 move_gap_both (PT
, PT_BYTE
);
4142 GAP_SIZE
+= inserted
;
4143 ZV_BYTE
-= inserted
;
4147 decode_coding_gap (&coding
, inserted
, inserted
);
4148 inserted
= coding
.produced_char
;
4149 coding_system
= CODING_ID_NAME (coding
.id
);
4151 else if (inserted
> 0)
4152 adjust_after_insert (PT
, PT_BYTE
, PT
+ inserted
, PT_BYTE
+ inserted
,
4155 /* Now INSERTED is measured in characters. */
4158 /* Use the conversion type to determine buffer-file-type
4159 (find-buffer-file-type is now used to help determine the
4161 if ((VECTORP (CODING_ID_EOL_TYPE (coding
.id
))
4162 || EQ (CODING_ID_EOL_TYPE (coding
.id
), Qunix
))
4163 && ! CODING_REQUIRE_DECODING (&coding
))
4164 current_buffer
->buffer_file_type
= Qt
;
4166 current_buffer
->buffer_file_type
= Qnil
;
4171 if (deferred_remove_unwind_protect
)
4172 /* If requested above, discard the unwind protect for closing the
4178 if (!EQ (current_buffer
->undo_list
, Qt
) && !nochange
)
4179 current_buffer
->undo_list
= Qnil
;
4183 current_buffer
->modtime
= st
.st_mtime
;
4184 current_buffer
->modtime_size
= st
.st_size
;
4185 current_buffer
->filename
= orig_filename
;
4188 SAVE_MODIFF
= MODIFF
;
4189 BUF_AUTOSAVE_MODIFF (current_buffer
) = MODIFF
;
4190 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4191 #ifdef CLASH_DETECTION
4194 if (!NILP (current_buffer
->file_truename
))
4195 unlock_file (current_buffer
->file_truename
);
4196 unlock_file (filename
);
4198 #endif /* CLASH_DETECTION */
4200 xsignal2 (Qfile_error
,
4201 build_string ("not a regular file"), orig_filename
);
4204 if (set_coding_system
)
4205 Vlast_coding_system_used
= coding_system
;
4207 if (! NILP (Ffboundp (Qafter_insert_file_set_coding
)))
4209 insval
= call2 (Qafter_insert_file_set_coding
, make_number (inserted
),
4211 if (! NILP (insval
))
4213 CHECK_NUMBER (insval
);
4214 inserted
= XFASTINT (insval
);
4218 /* Decode file format. */
4221 /* Don't run point motion or modification hooks when decoding. */
4222 int count
= SPECPDL_INDEX ();
4223 EMACS_INT old_inserted
= inserted
;
4224 specbind (Qinhibit_point_motion_hooks
, Qt
);
4225 specbind (Qinhibit_modification_hooks
, Qt
);
4227 /* Save old undo list and don't record undo for decoding. */
4228 old_undo
= current_buffer
->undo_list
;
4229 current_buffer
->undo_list
= Qt
;
4233 insval
= call3 (Qformat_decode
,
4234 Qnil
, make_number (inserted
), visit
);
4235 CHECK_NUMBER (insval
);
4236 inserted
= XFASTINT (insval
);
4240 /* If REPLACE is non-nil and we succeeded in not replacing the
4241 beginning or end of the buffer text with the file's contents,
4242 call format-decode with `point' positioned at the beginning
4243 of the buffer and `inserted' equalling the number of
4244 characters in the buffer. Otherwise, format-decode might
4245 fail to correctly analyze the beginning or end of the buffer.
4246 Hence we temporarily save `point' and `inserted' here and
4247 restore `point' iff format-decode did not insert or delete
4248 any text. Otherwise we leave `point' at point-min. */
4249 EMACS_INT opoint
= PT
;
4250 EMACS_INT opoint_byte
= PT_BYTE
;
4251 EMACS_INT oinserted
= ZV
- BEGV
;
4252 int ochars_modiff
= CHARS_MODIFF
;
4254 TEMP_SET_PT_BOTH (BEGV
, BEGV_BYTE
);
4255 insval
= call3 (Qformat_decode
,
4256 Qnil
, make_number (oinserted
), visit
);
4257 CHECK_NUMBER (insval
);
4258 if (ochars_modiff
== CHARS_MODIFF
)
4259 /* format_decode didn't modify buffer's characters => move
4260 point back to position before inserted text and leave
4261 value of inserted alone. */
4262 SET_PT_BOTH (opoint
, opoint_byte
);
4264 /* format_decode modified buffer's characters => consider
4265 entire buffer changed and leave point at point-min. */
4266 inserted
= XFASTINT (insval
);
4269 /* For consistency with format-decode call these now iff inserted > 0
4270 (martin 2007-06-28). */
4271 p
= Vafter_insert_file_functions
;
4276 insval
= call1 (XCAR (p
), make_number (inserted
));
4279 CHECK_NUMBER (insval
);
4280 inserted
= XFASTINT (insval
);
4285 /* For the rationale of this see the comment on
4286 format-decode above. */
4287 EMACS_INT opoint
= PT
;
4288 EMACS_INT opoint_byte
= PT_BYTE
;
4289 EMACS_INT oinserted
= ZV
- BEGV
;
4290 int ochars_modiff
= CHARS_MODIFF
;
4292 TEMP_SET_PT_BOTH (BEGV
, BEGV_BYTE
);
4293 insval
= call1 (XCAR (p
), make_number (oinserted
));
4296 CHECK_NUMBER (insval
);
4297 if (ochars_modiff
== CHARS_MODIFF
)
4298 /* after_insert_file_functions didn't modify
4299 buffer's characters => move point back to
4300 position before inserted text and leave value of
4302 SET_PT_BOTH (opoint
, opoint_byte
);
4304 /* after_insert_file_functions did modify buffer's
4305 characters => consider entire buffer changed and
4306 leave point at point-min. */
4307 inserted
= XFASTINT (insval
);
4317 current_buffer
->undo_list
= old_undo
;
4318 if (CONSP (old_undo
) && inserted
!= old_inserted
)
4320 /* Adjust the last undo record for the size change during
4321 the format conversion. */
4322 Lisp_Object tem
= XCAR (old_undo
);
4323 if (CONSP (tem
) && INTEGERP (XCAR (tem
))
4324 && INTEGERP (XCDR (tem
))
4325 && XFASTINT (XCDR (tem
)) == PT
+ old_inserted
)
4326 XSETCDR (tem
, make_number (PT
+ inserted
));
4330 /* If undo_list was Qt before, keep it that way.
4331 Otherwise start with an empty undo_list. */
4332 current_buffer
->undo_list
= EQ (old_undo
, Qt
) ? Qt
: Qnil
;
4334 unbind_to (count
, Qnil
);
4337 /* Call after-change hooks for the inserted text, aside from the case
4338 of normal visiting (not with REPLACE), which is done in a new buffer
4339 "before" the buffer is changed. */
4340 if (inserted
> 0 && total
> 0
4341 && (NILP (visit
) || !NILP (replace
)))
4343 signal_after_change (PT
, 0, inserted
);
4344 update_compositions (PT
, PT
, CHECK_BORDER
);
4348 && current_buffer
->modtime
== -1)
4350 /* If visiting nonexistent file, return nil. */
4351 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
4355 Fsignal (Qquit
, Qnil
);
4357 /* ??? Retval needs to be dealt with in all cases consistently. */
4359 val
= Fcons (orig_filename
,
4360 Fcons (make_number (inserted
),
4363 RETURN_UNGCPRO (unbind_to (count
, val
));
4366 static Lisp_Object
build_annotations (Lisp_Object
, Lisp_Object
);
4369 build_annotations_unwind (Lisp_Object arg
)
4371 Vwrite_region_annotation_buffers
= arg
;
4375 /* Decide the coding-system to encode the data with. */
4378 choose_write_coding_system (Lisp_Object start
, Lisp_Object end
, Lisp_Object filename
,
4379 Lisp_Object append
, Lisp_Object visit
, Lisp_Object lockname
,
4380 struct coding_system
*coding
)
4383 Lisp_Object eol_parent
= Qnil
;
4386 && NILP (Fstring_equal (current_buffer
->filename
,
4387 current_buffer
->auto_save_file_name
)))
4392 else if (!NILP (Vcoding_system_for_write
))
4394 val
= Vcoding_system_for_write
;
4395 if (coding_system_require_warning
4396 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4397 /* Confirm that VAL can surely encode the current region. */
4398 val
= call5 (Vselect_safe_coding_system_function
,
4399 start
, end
, Fcons (Qt
, Fcons (val
, Qnil
)),
4404 /* If the variable `buffer-file-coding-system' is set locally,
4405 it means that the file was read with some kind of code
4406 conversion or the variable is explicitly set by users. We
4407 had better write it out with the same coding system even if
4408 `enable-multibyte-characters' is nil.
4410 If it is not set locally, we anyway have to convert EOL
4411 format if the default value of `buffer-file-coding-system'
4412 tells that it is not Unix-like (LF only) format. */
4413 int using_default_coding
= 0;
4414 int force_raw_text
= 0;
4416 val
= current_buffer
->buffer_file_coding_system
;
4418 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4421 if (NILP (current_buffer
->enable_multibyte_characters
))
4427 /* Check file-coding-system-alist. */
4428 Lisp_Object args
[7], coding_systems
;
4430 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4431 args
[3] = filename
; args
[4] = append
; args
[5] = visit
;
4433 coding_systems
= Ffind_operation_coding_system (7, args
);
4434 if (CONSP (coding_systems
) && !NILP (XCDR (coding_systems
)))
4435 val
= XCDR (coding_systems
);
4440 /* If we still have not decided a coding system, use the
4441 default value of buffer-file-coding-system. */
4442 val
= current_buffer
->buffer_file_coding_system
;
4443 using_default_coding
= 1;
4446 if (! NILP (val
) && ! force_raw_text
)
4448 Lisp_Object spec
, attrs
;
4450 CHECK_CODING_SYSTEM_GET_SPEC (val
, spec
);
4451 attrs
= AREF (spec
, 0);
4452 if (EQ (CODING_ATTR_TYPE (attrs
), Qraw_text
))
4457 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4458 /* Confirm that VAL can surely encode the current region. */
4459 val
= call5 (Vselect_safe_coding_system_function
,
4460 start
, end
, val
, Qnil
, filename
);
4462 /* If the decided coding-system doesn't specify end-of-line
4463 format, we use that of
4464 `default-buffer-file-coding-system'. */
4465 if (! using_default_coding
4466 && ! NILP (buffer_defaults
.buffer_file_coding_system
))
4467 val
= (coding_inherit_eol_type
4468 (val
, buffer_defaults
.buffer_file_coding_system
));
4470 /* If we decide not to encode text, use `raw-text' or one of its
4473 val
= raw_text_coding_system (val
);
4476 val
= coding_inherit_eol_type (val
, eol_parent
);
4477 setup_coding_system (val
, coding
);
4479 if (!STRINGP (start
) && !NILP (current_buffer
->selective_display
))
4480 coding
->mode
|= CODING_MODE_SELECTIVE_DISPLAY
;
4484 DEFUN ("write-region", Fwrite_region
, Swrite_region
, 3, 7,
4485 "r\nFWrite region to file: \ni\ni\ni\np",
4486 doc
: /* Write current region into specified file.
4487 When called from a program, requires three arguments:
4488 START, END and FILENAME. START and END are normally buffer positions
4489 specifying the part of the buffer to write.
4490 If START is nil, that means to use the entire buffer contents.
4491 If START is a string, then output that string to the file
4492 instead of any buffer contents; END is ignored.
4494 Optional fourth argument APPEND if non-nil means
4495 append to existing file contents (if any). If it is an integer,
4496 seek to that offset in the file before writing.
4497 Optional fifth argument VISIT, if t or a string, means
4498 set the last-save-file-modtime of buffer to this file's modtime
4499 and mark buffer not modified.
4500 If VISIT is a string, it is a second file name;
4501 the output goes to FILENAME, but the buffer is marked as visiting VISIT.
4502 VISIT is also the file name to lock and unlock for clash detection.
4503 If VISIT is neither t nor nil nor a string,
4504 that means do not display the \"Wrote file\" message.
4505 The optional sixth arg LOCKNAME, if non-nil, specifies the name to
4506 use for locking and unlocking, overriding FILENAME and VISIT.
4507 The optional seventh arg MUSTBENEW, if non-nil, insists on a check
4508 for an existing file with the same name. If MUSTBENEW is `excl',
4509 that means to get an error if the file already exists; never overwrite.
4510 If MUSTBENEW is neither nil nor `excl', that means ask for
4511 confirmation before overwriting, but do go ahead and overwrite the file
4512 if the user confirms.
4514 This does code conversion according to the value of
4515 `coding-system-for-write', `buffer-file-coding-system', or
4516 `file-coding-system-alist', and sets the variable
4517 `last-coding-system-used' to the coding system actually used.
4519 This calls `write-region-annotate-functions' at the start, and
4520 `write-region-post-annotation-function' at the end. */)
4521 (Lisp_Object start
, Lisp_Object end
, Lisp_Object filename
, Lisp_Object append
, Lisp_Object visit
, Lisp_Object lockname
, Lisp_Object mustbenew
)
4526 const unsigned char *fn
;
4528 int count
= SPECPDL_INDEX ();
4530 Lisp_Object handler
;
4531 Lisp_Object visit_file
;
4532 Lisp_Object annotations
;
4533 Lisp_Object encoded_filename
;
4534 int visiting
= (EQ (visit
, Qt
) || STRINGP (visit
));
4535 int quietly
= !NILP (visit
);
4536 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
4537 struct buffer
*given_buffer
;
4539 int buffer_file_type
= O_BINARY
;
4541 struct coding_system coding
;
4543 if (current_buffer
->base_buffer
&& visiting
)
4544 error ("Cannot do file visiting in an indirect buffer");
4546 if (!NILP (start
) && !STRINGP (start
))
4547 validate_region (&start
, &end
);
4550 GCPRO5 (start
, filename
, visit
, visit_file
, lockname
);
4552 filename
= Fexpand_file_name (filename
, Qnil
);
4554 if (!NILP (mustbenew
) && !EQ (mustbenew
, Qexcl
))
4555 barf_or_query_if_file_exists (filename
, "overwrite", 1, 0, 1);
4557 if (STRINGP (visit
))
4558 visit_file
= Fexpand_file_name (visit
, Qnil
);
4560 visit_file
= filename
;
4562 if (NILP (lockname
))
4563 lockname
= visit_file
;
4567 /* If the file name has special constructs in it,
4568 call the corresponding file handler. */
4569 handler
= Ffind_file_name_handler (filename
, Qwrite_region
);
4570 /* If FILENAME has no handler, see if VISIT has one. */
4571 if (NILP (handler
) && STRINGP (visit
))
4572 handler
= Ffind_file_name_handler (visit
, Qwrite_region
);
4574 if (!NILP (handler
))
4577 val
= call6 (handler
, Qwrite_region
, start
, end
,
4578 filename
, append
, visit
);
4582 SAVE_MODIFF
= MODIFF
;
4583 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4584 current_buffer
->filename
= visit_file
;
4590 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
4592 /* Special kludge to simplify auto-saving. */
4595 /* Do it later, so write-region-annotate-function can work differently
4596 if we save "the buffer" vs "a region".
4597 This is useful in tar-mode. --Stef
4598 XSETFASTINT (start, BEG);
4599 XSETFASTINT (end, Z); */
4603 record_unwind_protect (build_annotations_unwind
,
4604 Vwrite_region_annotation_buffers
);
4605 Vwrite_region_annotation_buffers
= Fcons (Fcurrent_buffer (), Qnil
);
4606 count1
= SPECPDL_INDEX ();
4608 given_buffer
= current_buffer
;
4610 if (!STRINGP (start
))
4612 annotations
= build_annotations (start
, end
);
4614 if (current_buffer
!= given_buffer
)
4616 XSETFASTINT (start
, BEGV
);
4617 XSETFASTINT (end
, ZV
);
4623 XSETFASTINT (start
, BEGV
);
4624 XSETFASTINT (end
, ZV
);
4629 GCPRO5 (start
, filename
, annotations
, visit_file
, lockname
);
4631 /* Decide the coding-system to encode the data with.
4632 We used to make this choice before calling build_annotations, but that
4633 leads to problems when a write-annotate-function takes care of
4634 unsavable chars (as was the case with X-Symbol). */
4635 Vlast_coding_system_used
4636 = choose_write_coding_system (start
, end
, filename
,
4637 append
, visit
, lockname
, &coding
);
4639 #ifdef CLASH_DETECTION
4641 lock_file (lockname
);
4642 #endif /* CLASH_DETECTION */
4644 encoded_filename
= ENCODE_FILE (filename
);
4646 fn
= SDATA (encoded_filename
);
4650 desc
= emacs_open (fn
, O_WRONLY
| buffer_file_type
, 0);
4651 #else /* not DOS_NT */
4652 desc
= emacs_open (fn
, O_WRONLY
, 0);
4653 #endif /* not DOS_NT */
4655 if (desc
< 0 && (NILP (append
) || errno
== ENOENT
))
4657 desc
= emacs_open (fn
,
4658 O_WRONLY
| O_CREAT
| buffer_file_type
4659 | (EQ (mustbenew
, Qexcl
) ? O_EXCL
: O_TRUNC
),
4660 S_IREAD
| S_IWRITE
);
4661 #else /* not DOS_NT */
4662 desc
= emacs_open (fn
, O_WRONLY
| O_TRUNC
| O_CREAT
4663 | (EQ (mustbenew
, Qexcl
) ? O_EXCL
: 0),
4664 auto_saving
? auto_save_mode_bits
: 0666);
4665 #endif /* not DOS_NT */
4669 #ifdef CLASH_DETECTION
4671 if (!auto_saving
) unlock_file (lockname
);
4673 #endif /* CLASH_DETECTION */
4675 report_file_error ("Opening output file", Fcons (filename
, Qnil
));
4678 record_unwind_protect (close_file_unwind
, make_number (desc
));
4680 if (!NILP (append
) && !NILP (Ffile_regular_p (filename
)))
4684 if (NUMBERP (append
))
4685 ret
= lseek (desc
, XINT (append
), 1);
4687 ret
= lseek (desc
, 0, 2);
4690 #ifdef CLASH_DETECTION
4691 if (!auto_saving
) unlock_file (lockname
);
4692 #endif /* CLASH_DETECTION */
4694 report_file_error ("Lseek error", Fcons (filename
, Qnil
));
4703 if (STRINGP (start
))
4705 failure
= 0 > a_write (desc
, start
, 0, SCHARS (start
),
4706 &annotations
, &coding
);
4709 else if (XINT (start
) != XINT (end
))
4711 failure
= 0 > a_write (desc
, Qnil
,
4712 XINT (start
), XINT (end
) - XINT (start
),
4713 &annotations
, &coding
);
4718 /* If file was empty, still need to write the annotations */
4719 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4720 failure
= 0 > a_write (desc
, Qnil
, XINT (end
), 0, &annotations
, &coding
);
4724 if (CODING_REQUIRE_FLUSHING (&coding
)
4725 && !(coding
.mode
& CODING_MODE_LAST_BLOCK
)
4728 /* We have to flush out a data. */
4729 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4730 failure
= 0 > e_write (desc
, Qnil
, 1, 1, &coding
);
4737 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
4738 Disk full in NFS may be reported here. */
4739 /* mib says that closing the file will try to write as fast as NFS can do
4740 it, and that means the fsync here is not crucial for autosave files. */
4741 if (!auto_saving
&& !write_region_inhibit_fsync
&& fsync (desc
) < 0)
4743 /* If fsync fails with EINTR, don't treat that as serious. Also
4744 ignore EINVAL which happens when fsync is not supported on this
4746 if (errno
!= EINTR
&& errno
!= EINVAL
)
4747 failure
= 1, save_errno
= errno
;
4751 /* NFS can report a write failure now. */
4752 if (emacs_close (desc
) < 0)
4753 failure
= 1, save_errno
= errno
;
4757 /* Discard the unwind protect for close_file_unwind. */
4758 specpdl_ptr
= specpdl
+ count1
;
4760 /* Call write-region-post-annotation-function. */
4761 while (CONSP (Vwrite_region_annotation_buffers
))
4763 Lisp_Object buf
= XCAR (Vwrite_region_annotation_buffers
);
4764 if (!NILP (Fbuffer_live_p (buf
)))
4767 if (FUNCTIONP (Vwrite_region_post_annotation_function
))
4768 call0 (Vwrite_region_post_annotation_function
);
4770 Vwrite_region_annotation_buffers
4771 = XCDR (Vwrite_region_annotation_buffers
);
4774 unbind_to (count
, Qnil
);
4776 #ifdef CLASH_DETECTION
4778 unlock_file (lockname
);
4779 #endif /* CLASH_DETECTION */
4781 /* Do this before reporting IO error
4782 to avoid a "file has changed on disk" warning on
4783 next attempt to save. */
4786 current_buffer
->modtime
= st
.st_mtime
;
4787 current_buffer
->modtime_size
= st
.st_size
;
4791 error ("IO error writing %s: %s", SDATA (filename
),
4792 emacs_strerror (save_errno
));
4796 SAVE_MODIFF
= MODIFF
;
4797 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4798 current_buffer
->filename
= visit_file
;
4799 update_mode_lines
++;
4804 && ! NILP (Fstring_equal (current_buffer
->filename
,
4805 current_buffer
->auto_save_file_name
)))
4806 SAVE_MODIFF
= MODIFF
;
4812 message_with_string ((INTEGERP (append
)
4822 Lisp_Object
merge (Lisp_Object
, Lisp_Object
, Lisp_Object
);
4824 DEFUN ("car-less-than-car", Fcar_less_than_car
, Scar_less_than_car
, 2, 2, 0,
4825 doc
: /* Return t if (car A) is numerically less than (car B). */)
4826 (Lisp_Object a
, Lisp_Object b
)
4828 return Flss (Fcar (a
), Fcar (b
));
4831 /* Build the complete list of annotations appropriate for writing out
4832 the text between START and END, by calling all the functions in
4833 write-region-annotate-functions and merging the lists they return.
4834 If one of these functions switches to a different buffer, we assume
4835 that buffer contains altered text. Therefore, the caller must
4836 make sure to restore the current buffer in all cases,
4837 as save-excursion would do. */
4840 build_annotations (Lisp_Object start
, Lisp_Object end
)
4842 Lisp_Object annotations
;
4844 struct gcpro gcpro1
, gcpro2
;
4845 Lisp_Object original_buffer
;
4846 int i
, used_global
= 0;
4848 XSETBUFFER (original_buffer
, current_buffer
);
4851 p
= Vwrite_region_annotate_functions
;
4852 GCPRO2 (annotations
, p
);
4855 struct buffer
*given_buffer
= current_buffer
;
4856 if (EQ (Qt
, XCAR (p
)) && !used_global
)
4857 { /* Use the global value of the hook. */
4860 arg
[0] = Fdefault_value (Qwrite_region_annotate_functions
);
4862 p
= Fappend (2, arg
);
4865 Vwrite_region_annotations_so_far
= annotations
;
4866 res
= call2 (XCAR (p
), start
, end
);
4867 /* If the function makes a different buffer current,
4868 assume that means this buffer contains altered text to be output.
4869 Reset START and END from the buffer bounds
4870 and discard all previous annotations because they should have
4871 been dealt with by this function. */
4872 if (current_buffer
!= given_buffer
)
4874 Vwrite_region_annotation_buffers
4875 = Fcons (Fcurrent_buffer (),
4876 Vwrite_region_annotation_buffers
);
4877 XSETFASTINT (start
, BEGV
);
4878 XSETFASTINT (end
, ZV
);
4881 Flength (res
); /* Check basic validity of return value */
4882 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
4886 /* Now do the same for annotation functions implied by the file-format */
4887 if (auto_saving
&& (!EQ (current_buffer
->auto_save_file_format
, Qt
)))
4888 p
= current_buffer
->auto_save_file_format
;
4890 p
= current_buffer
->file_format
;
4891 for (i
= 0; CONSP (p
); p
= XCDR (p
), ++i
)
4893 struct buffer
*given_buffer
= current_buffer
;
4895 Vwrite_region_annotations_so_far
= annotations
;
4897 /* Value is either a list of annotations or nil if the function
4898 has written annotations to a temporary buffer, which is now
4900 res
= call5 (Qformat_annotate_function
, XCAR (p
), start
, end
,
4901 original_buffer
, make_number (i
));
4902 if (current_buffer
!= given_buffer
)
4904 XSETFASTINT (start
, BEGV
);
4905 XSETFASTINT (end
, ZV
);
4910 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
4918 /* Write to descriptor DESC the NCHARS chars starting at POS of STRING.
4919 If STRING is nil, POS is the character position in the current buffer.
4920 Intersperse with them the annotations from *ANNOT
4921 which fall within the range of POS to POS + NCHARS,
4922 each at its appropriate position.
4924 We modify *ANNOT by discarding elements as we use them up.
4926 The return value is negative in case of system call failure. */
4929 a_write (int desc
, Lisp_Object string
, int pos
, register int nchars
, Lisp_Object
*annot
, struct coding_system
*coding
)
4933 int lastpos
= pos
+ nchars
;
4935 while (NILP (*annot
) || CONSP (*annot
))
4937 tem
= Fcar_safe (Fcar (*annot
));
4940 nextpos
= XFASTINT (tem
);
4942 /* If there are no more annotations in this range,
4943 output the rest of the range all at once. */
4944 if (! (nextpos
>= pos
&& nextpos
<= lastpos
))
4945 return e_write (desc
, string
, pos
, lastpos
, coding
);
4947 /* Output buffer text up to the next annotation's position. */
4950 if (0 > e_write (desc
, string
, pos
, nextpos
, coding
))
4954 /* Output the annotation. */
4955 tem
= Fcdr (Fcar (*annot
));
4958 if (0 > e_write (desc
, tem
, 0, SCHARS (tem
), coding
))
4961 *annot
= Fcdr (*annot
);
4967 /* Write text in the range START and END into descriptor DESC,
4968 encoding them with coding system CODING. If STRING is nil, START
4969 and END are character positions of the current buffer, else they
4970 are indexes to the string STRING. */
4973 e_write (int desc
, Lisp_Object string
, int start
, int end
, struct coding_system
*coding
)
4975 if (STRINGP (string
))
4978 end
= SCHARS (string
);
4981 /* We used to have a code for handling selective display here. But,
4982 now it is handled within encode_coding. */
4986 if (STRINGP (string
))
4988 coding
->src_multibyte
= SCHARS (string
) < SBYTES (string
);
4989 if (CODING_REQUIRE_ENCODING (coding
))
4991 encode_coding_object (coding
, string
,
4992 start
, string_char_to_byte (string
, start
),
4993 end
, string_char_to_byte (string
, end
), Qt
);
4997 coding
->dst_object
= string
;
4998 coding
->consumed_char
= SCHARS (string
);
4999 coding
->produced
= SBYTES (string
);
5004 int start_byte
= CHAR_TO_BYTE (start
);
5005 int end_byte
= CHAR_TO_BYTE (end
);
5007 coding
->src_multibyte
= (end
- start
) < (end_byte
- start_byte
);
5008 if (CODING_REQUIRE_ENCODING (coding
))
5010 encode_coding_object (coding
, Fcurrent_buffer (),
5011 start
, start_byte
, end
, end_byte
, Qt
);
5015 coding
->dst_object
= Qnil
;
5016 coding
->dst_pos_byte
= start_byte
;
5017 if (start
>= GPT
|| end
<= GPT
)
5019 coding
->consumed_char
= end
- start
;
5020 coding
->produced
= end_byte
- start_byte
;
5024 coding
->consumed_char
= GPT
- start
;
5025 coding
->produced
= GPT_BYTE
- start_byte
;
5030 if (coding
->produced
> 0)
5034 STRINGP (coding
->dst_object
)
5035 ? SDATA (coding
->dst_object
)
5036 : BYTE_POS_ADDR (coding
->dst_pos_byte
),
5039 if (coding
->produced
)
5042 start
+= coding
->consumed_char
;
5048 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime
,
5049 Sverify_visited_file_modtime
, 0, 1, 0,
5050 doc
: /* Return t if last mod time of BUF's visited file matches what BUF records.
5051 This means that the file has not been changed since it was visited or saved.
5052 If BUF is omitted or nil, it defaults to the current buffer.
5053 See Info node `(elisp)Modification Time' for more details. */)
5058 Lisp_Object handler
;
5059 Lisp_Object filename
;
5069 if (!STRINGP (b
->filename
)) return Qt
;
5070 if (b
->modtime
== 0) return Qt
;
5072 /* If the file name has special constructs in it,
5073 call the corresponding file handler. */
5074 handler
= Ffind_file_name_handler (b
->filename
,
5075 Qverify_visited_file_modtime
);
5076 if (!NILP (handler
))
5077 return call2 (handler
, Qverify_visited_file_modtime
, buf
);
5079 filename
= ENCODE_FILE (b
->filename
);
5081 if (stat (SDATA (filename
), &st
) < 0)
5083 /* If the file doesn't exist now and didn't exist before,
5084 we say that it isn't modified, provided the error is a tame one. */
5085 if (errno
== ENOENT
|| errno
== EACCES
|| errno
== ENOTDIR
)
5090 if ((st
.st_mtime
== b
->modtime
5091 /* If both are positive, accept them if they are off by one second. */
5092 || (st
.st_mtime
> 0 && b
->modtime
> 0
5093 && (st
.st_mtime
== b
->modtime
+ 1
5094 || st
.st_mtime
== b
->modtime
- 1)))
5095 && (st
.st_size
== b
->modtime_size
5096 || b
->modtime_size
< 0))
5101 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime
,
5102 Sclear_visited_file_modtime
, 0, 0, 0,
5103 doc
: /* Clear out records of last mod time of visited file.
5104 Next attempt to save will certainly not complain of a discrepancy. */)
5107 current_buffer
->modtime
= 0;
5108 current_buffer
->modtime_size
= -1;
5112 DEFUN ("visited-file-modtime", Fvisited_file_modtime
,
5113 Svisited_file_modtime
, 0, 0, 0,
5114 doc
: /* Return the current buffer's recorded visited file modification time.
5115 The value is a list of the form (HIGH LOW), like the time values
5116 that `file-attributes' returns. If the current buffer has no recorded
5117 file modification time, this function returns 0.
5118 See Info node `(elisp)Modification Time' for more details. */)
5121 if (! current_buffer
->modtime
)
5122 return make_number (0);
5123 return make_time ((time_t) current_buffer
->modtime
);
5126 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime
,
5127 Sset_visited_file_modtime
, 0, 1, 0,
5128 doc
: /* Update buffer's recorded modification time from the visited file's time.
5129 Useful if the buffer was not read from the file normally
5130 or if the file itself has been changed for some known benign reason.
5131 An argument specifies the modification time value to use
5132 \(instead of that of the visited file), in the form of a list
5133 \(HIGH . LOW) or (HIGH LOW). */)
5134 (Lisp_Object time_list
)
5136 if (!NILP (time_list
))
5138 current_buffer
->modtime
= cons_to_long (time_list
);
5139 current_buffer
->modtime_size
= -1;
5143 register Lisp_Object filename
;
5145 Lisp_Object handler
;
5147 filename
= Fexpand_file_name (current_buffer
->filename
, Qnil
);
5149 /* If the file name has special constructs in it,
5150 call the corresponding file handler. */
5151 handler
= Ffind_file_name_handler (filename
, Qset_visited_file_modtime
);
5152 if (!NILP (handler
))
5153 /* The handler can find the file name the same way we did. */
5154 return call2 (handler
, Qset_visited_file_modtime
, Qnil
);
5156 filename
= ENCODE_FILE (filename
);
5158 if (stat (SDATA (filename
), &st
) >= 0)
5160 current_buffer
->modtime
= st
.st_mtime
;
5161 current_buffer
->modtime_size
= st
.st_size
;
5169 auto_save_error (Lisp_Object error
)
5171 Lisp_Object args
[3], msg
;
5173 struct gcpro gcpro1
;
5177 auto_save_error_occurred
= 1;
5179 ring_bell (XFRAME (selected_frame
));
5181 args
[0] = build_string ("Auto-saving %s: %s");
5182 args
[1] = current_buffer
->name
;
5183 args
[2] = Ferror_message_string (error
);
5184 msg
= Fformat (3, args
);
5186 nbytes
= SBYTES (msg
);
5187 SAFE_ALLOCA (msgbuf
, char *, nbytes
);
5188 memcpy (msgbuf
, SDATA (msg
), nbytes
);
5190 for (i
= 0; i
< 3; ++i
)
5193 message2 (msgbuf
, nbytes
, STRING_MULTIBYTE (msg
));
5195 message2_nolog (msgbuf
, nbytes
, STRING_MULTIBYTE (msg
));
5196 Fsleep_for (make_number (1), Qnil
);
5210 auto_save_mode_bits
= 0666;
5212 /* Get visited file's mode to become the auto save file's mode. */
5213 if (! NILP (current_buffer
->filename
))
5215 if (stat (SDATA (current_buffer
->filename
), &st
) >= 0)
5216 /* But make sure we can overwrite it later! */
5217 auto_save_mode_bits
= st
.st_mode
| 0600;
5218 else if ((modes
= Ffile_modes (current_buffer
->filename
),
5220 /* Remote files don't cooperate with stat. */
5221 auto_save_mode_bits
= XINT (modes
) | 0600;
5225 Fwrite_region (Qnil
, Qnil
, current_buffer
->auto_save_file_name
, Qnil
,
5226 NILP (Vauto_save_visited_file_name
) ? Qlambda
: Qt
,
5231 do_auto_save_unwind (Lisp_Object arg
) /* used as unwind-protect function */
5234 FILE *stream
= (FILE *) XSAVE_VALUE (arg
)->pointer
;
5246 do_auto_save_unwind_1 (Lisp_Object value
) /* used as unwind-protect function */
5249 minibuffer_auto_raise
= XINT (value
);
5254 do_auto_save_make_dir (Lisp_Object dir
)
5258 call2 (Qmake_directory
, dir
, Qt
);
5259 XSETFASTINT (mode
, 0700);
5260 return Fset_file_modes (dir
, mode
);
5264 do_auto_save_eh (Lisp_Object ignore
)
5269 DEFUN ("do-auto-save", Fdo_auto_save
, Sdo_auto_save
, 0, 2, "",
5270 doc
: /* Auto-save all buffers that need it.
5271 This is all buffers that have auto-saving enabled
5272 and are changed since last auto-saved.
5273 Auto-saving writes the buffer into a file
5274 so that your editing is not lost if the system crashes.
5275 This file is not the file you visited; that changes only when you save.
5276 Normally we run the normal hook `auto-save-hook' before saving.
5278 A non-nil NO-MESSAGE argument means do not print any message if successful.
5279 A non-nil CURRENT-ONLY argument means save only current buffer. */)
5280 (Lisp_Object no_message
, Lisp_Object current_only
)
5282 struct buffer
*old
= current_buffer
, *b
;
5283 Lisp_Object tail
, buf
;
5285 int do_handled_files
;
5287 FILE *stream
= NULL
;
5288 int count
= SPECPDL_INDEX ();
5289 int orig_minibuffer_auto_raise
= minibuffer_auto_raise
;
5290 int old_message_p
= 0;
5291 struct gcpro gcpro1
, gcpro2
;
5293 if (max_specpdl_size
< specpdl_size
+ 40)
5294 max_specpdl_size
= specpdl_size
+ 40;
5299 if (NILP (no_message
))
5301 old_message_p
= push_message ();
5302 record_unwind_protect (pop_message_unwind
, Qnil
);
5305 /* Ordinarily don't quit within this function,
5306 but don't make it impossible to quit (in case we get hung in I/O). */
5310 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
5311 point to non-strings reached from Vbuffer_alist. */
5313 if (!NILP (Vrun_hooks
))
5314 call1 (Vrun_hooks
, intern ("auto-save-hook"));
5316 if (STRINGP (Vauto_save_list_file_name
))
5318 Lisp_Object listfile
;
5320 listfile
= Fexpand_file_name (Vauto_save_list_file_name
, Qnil
);
5322 /* Don't try to create the directory when shutting down Emacs,
5323 because creating the directory might signal an error, and
5324 that would leave Emacs in a strange state. */
5325 if (!NILP (Vrun_hooks
))
5329 GCPRO2 (dir
, listfile
);
5330 dir
= Ffile_name_directory (listfile
);
5331 if (NILP (Ffile_directory_p (dir
)))
5332 internal_condition_case_1 (do_auto_save_make_dir
,
5333 dir
, Fcons (Fcons (Qfile_error
, Qnil
), Qnil
),
5338 stream
= fopen (SDATA (listfile
), "w");
5341 record_unwind_protect (do_auto_save_unwind
,
5342 make_save_value (stream
, 0));
5343 record_unwind_protect (do_auto_save_unwind_1
,
5344 make_number (minibuffer_auto_raise
));
5345 minibuffer_auto_raise
= 0;
5347 auto_save_error_occurred
= 0;
5349 /* On first pass, save all files that don't have handlers.
5350 On second pass, save all files that do have handlers.
5352 If Emacs is crashing, the handlers may tweak what is causing
5353 Emacs to crash in the first place, and it would be a shame if
5354 Emacs failed to autosave perfectly ordinary files because it
5355 couldn't handle some ange-ftp'd file. */
5357 for (do_handled_files
= 0; do_handled_files
< 2; do_handled_files
++)
5358 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
5360 buf
= XCDR (XCAR (tail
));
5363 /* Record all the buffers that have auto save mode
5364 in the special file that lists them. For each of these buffers,
5365 Record visited name (if any) and auto save name. */
5366 if (STRINGP (b
->auto_save_file_name
)
5367 && stream
!= NULL
&& do_handled_files
== 0)
5370 if (!NILP (b
->filename
))
5372 fwrite (SDATA (b
->filename
), 1,
5373 SBYTES (b
->filename
), stream
);
5375 putc ('\n', stream
);
5376 fwrite (SDATA (b
->auto_save_file_name
), 1,
5377 SBYTES (b
->auto_save_file_name
), stream
);
5378 putc ('\n', stream
);
5382 if (!NILP (current_only
)
5383 && b
!= current_buffer
)
5386 /* Don't auto-save indirect buffers.
5387 The base buffer takes care of it. */
5391 /* Check for auto save enabled
5392 and file changed since last auto save
5393 and file changed since last real save. */
5394 if (STRINGP (b
->auto_save_file_name
)
5395 && BUF_SAVE_MODIFF (b
) < BUF_MODIFF (b
)
5396 && BUF_AUTOSAVE_MODIFF (b
) < BUF_MODIFF (b
)
5397 /* -1 means we've turned off autosaving for a while--see below. */
5398 && XINT (b
->save_length
) >= 0
5399 && (do_handled_files
5400 || NILP (Ffind_file_name_handler (b
->auto_save_file_name
,
5403 EMACS_TIME before_time
, after_time
;
5405 EMACS_GET_TIME (before_time
);
5407 /* If we had a failure, don't try again for 20 minutes. */
5408 if (b
->auto_save_failure_time
>= 0
5409 && EMACS_SECS (before_time
) - b
->auto_save_failure_time
< 1200)
5412 set_buffer_internal (b
);
5413 if (NILP (Vauto_save_include_big_deletions
)
5414 && (XFASTINT (b
->save_length
) * 10
5415 > (BUF_Z (b
) - BUF_BEG (b
)) * 13)
5416 /* A short file is likely to change a large fraction;
5417 spare the user annoying messages. */
5418 && XFASTINT (b
->save_length
) > 5000
5419 /* These messages are frequent and annoying for `*mail*'. */
5420 && !EQ (b
->filename
, Qnil
)
5421 && NILP (no_message
))
5423 /* It has shrunk too much; turn off auto-saving here. */
5424 minibuffer_auto_raise
= orig_minibuffer_auto_raise
;
5425 message_with_string ("Buffer %s has shrunk a lot; auto save disabled in that buffer until next real save",
5427 minibuffer_auto_raise
= 0;
5428 /* Turn off auto-saving until there's a real save,
5429 and prevent any more warnings. */
5430 XSETINT (b
->save_length
, -1);
5431 Fsleep_for (make_number (1), Qnil
);
5434 if (!auto_saved
&& NILP (no_message
))
5435 message1 ("Auto-saving...");
5436 internal_condition_case (auto_save_1
, Qt
, auto_save_error
);
5438 BUF_AUTOSAVE_MODIFF (b
) = BUF_MODIFF (b
);
5439 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
5440 set_buffer_internal (old
);
5442 EMACS_GET_TIME (after_time
);
5444 /* If auto-save took more than 60 seconds,
5445 assume it was an NFS failure that got a timeout. */
5446 if (EMACS_SECS (after_time
) - EMACS_SECS (before_time
) > 60)
5447 b
->auto_save_failure_time
= EMACS_SECS (after_time
);
5451 /* Prevent another auto save till enough input events come in. */
5452 record_auto_save ();
5454 if (auto_saved
&& NILP (no_message
))
5458 /* If we are going to restore an old message,
5459 give time to read ours. */
5460 sit_for (make_number (1), 0, 0);
5463 else if (!auto_save_error_occurred
)
5464 /* Don't overwrite the error message if an error occurred.
5465 If we displayed a message and then restored a state
5466 with no message, leave a "done" message on the screen. */
5467 message1 ("Auto-saving...done");
5472 /* This restores the message-stack status. */
5473 unbind_to (count
, Qnil
);
5477 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved
,
5478 Sset_buffer_auto_saved
, 0, 0, 0,
5479 doc
: /* Mark current buffer as auto-saved with its current text.
5480 No auto-save file will be written until the buffer changes again. */)
5483 /* FIXME: This should not be called in indirect buffers, since
5484 they're not autosaved. */
5485 BUF_AUTOSAVE_MODIFF (current_buffer
) = MODIFF
;
5486 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
5487 current_buffer
->auto_save_failure_time
= -1;
5491 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure
,
5492 Sclear_buffer_auto_save_failure
, 0, 0, 0,
5493 doc
: /* Clear any record of a recent auto-save failure in the current buffer. */)
5496 current_buffer
->auto_save_failure_time
= -1;
5500 DEFUN ("recent-auto-save-p", Frecent_auto_save_p
, Srecent_auto_save_p
,
5502 doc
: /* Return t if current buffer has been auto-saved recently.
5503 More precisely, if it has been auto-saved since last read from or saved
5504 in the visited file. If the buffer has no visited file,
5505 then any auto-save counts as "recent". */)
5508 /* FIXME: maybe we should return nil for indirect buffers since
5509 they're never autosaved. */
5510 return (SAVE_MODIFF
< BUF_AUTOSAVE_MODIFF (current_buffer
) ? Qt
: Qnil
);
5513 /* Reading and completing file names */
5515 DEFUN ("next-read-file-uses-dialog-p", Fnext_read_file_uses_dialog_p
,
5516 Snext_read_file_uses_dialog_p
, 0, 0, 0,
5517 doc
: /* Return t if a call to `read-file-name' will use a dialog.
5518 The return value is only relevant for a call to `read-file-name' that happens
5519 before any other event (mouse or keypress) is handled. */)
5522 #if defined (USE_MOTIF) || defined (HAVE_NTGUI) || defined (USE_GTK)
5523 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
5533 Fread_file_name (Lisp_Object prompt
, Lisp_Object dir
, Lisp_Object default_filename
, Lisp_Object mustmatch
, Lisp_Object initial
, Lisp_Object predicate
)
5535 struct gcpro gcpro1
, gcpro2
;
5536 Lisp_Object args
[7];
5538 GCPRO1 (default_filename
);
5539 args
[0] = intern ("read-file-name");
5542 args
[3] = default_filename
;
5543 args
[4] = mustmatch
;
5545 args
[6] = predicate
;
5546 RETURN_UNGCPRO (Ffuncall (7, args
));
5551 syms_of_fileio (void)
5553 Qoperations
= intern_c_string ("operations");
5554 Qexpand_file_name
= intern_c_string ("expand-file-name");
5555 Qsubstitute_in_file_name
= intern_c_string ("substitute-in-file-name");
5556 Qdirectory_file_name
= intern_c_string ("directory-file-name");
5557 Qfile_name_directory
= intern_c_string ("file-name-directory");
5558 Qfile_name_nondirectory
= intern_c_string ("file-name-nondirectory");
5559 Qunhandled_file_name_directory
= intern_c_string ("unhandled-file-name-directory");
5560 Qfile_name_as_directory
= intern_c_string ("file-name-as-directory");
5561 Qcopy_file
= intern_c_string ("copy-file");
5562 Qmake_directory_internal
= intern_c_string ("make-directory-internal");
5563 Qmake_directory
= intern_c_string ("make-directory");
5564 Qdelete_directory_internal
= intern_c_string ("delete-directory-internal");
5565 Qdelete_file
= intern_c_string ("delete-file");
5566 Qrename_file
= intern_c_string ("rename-file");
5567 Qadd_name_to_file
= intern_c_string ("add-name-to-file");
5568 Qmake_symbolic_link
= intern_c_string ("make-symbolic-link");
5569 Qfile_exists_p
= intern_c_string ("file-exists-p");
5570 Qfile_executable_p
= intern_c_string ("file-executable-p");
5571 Qfile_readable_p
= intern_c_string ("file-readable-p");
5572 Qfile_writable_p
= intern_c_string ("file-writable-p");
5573 Qfile_symlink_p
= intern_c_string ("file-symlink-p");
5574 Qaccess_file
= intern_c_string ("access-file");
5575 Qfile_directory_p
= intern_c_string ("file-directory-p");
5576 Qfile_regular_p
= intern_c_string ("file-regular-p");
5577 Qfile_accessible_directory_p
= intern_c_string ("file-accessible-directory-p");
5578 Qfile_modes
= intern_c_string ("file-modes");
5579 Qset_file_modes
= intern_c_string ("set-file-modes");
5580 Qset_file_times
= intern_c_string ("set-file-times");
5581 Qfile_selinux_context
= intern_c_string("file-selinux-context");
5582 Qset_file_selinux_context
= intern_c_string("set-file-selinux-context");
5583 Qfile_newer_than_file_p
= intern_c_string ("file-newer-than-file-p");
5584 Qinsert_file_contents
= intern_c_string ("insert-file-contents");
5585 Qwrite_region
= intern_c_string ("write-region");
5586 Qverify_visited_file_modtime
= intern_c_string ("verify-visited-file-modtime");
5587 Qset_visited_file_modtime
= intern_c_string ("set-visited-file-modtime");
5588 Qauto_save_coding
= intern_c_string ("auto-save-coding");
5590 staticpro (&Qoperations
);
5591 staticpro (&Qexpand_file_name
);
5592 staticpro (&Qsubstitute_in_file_name
);
5593 staticpro (&Qdirectory_file_name
);
5594 staticpro (&Qfile_name_directory
);
5595 staticpro (&Qfile_name_nondirectory
);
5596 staticpro (&Qunhandled_file_name_directory
);
5597 staticpro (&Qfile_name_as_directory
);
5598 staticpro (&Qcopy_file
);
5599 staticpro (&Qmake_directory_internal
);
5600 staticpro (&Qmake_directory
);
5601 staticpro (&Qdelete_directory_internal
);
5602 staticpro (&Qdelete_file
);
5603 staticpro (&Qrename_file
);
5604 staticpro (&Qadd_name_to_file
);
5605 staticpro (&Qmake_symbolic_link
);
5606 staticpro (&Qfile_exists_p
);
5607 staticpro (&Qfile_executable_p
);
5608 staticpro (&Qfile_readable_p
);
5609 staticpro (&Qfile_writable_p
);
5610 staticpro (&Qaccess_file
);
5611 staticpro (&Qfile_symlink_p
);
5612 staticpro (&Qfile_directory_p
);
5613 staticpro (&Qfile_regular_p
);
5614 staticpro (&Qfile_accessible_directory_p
);
5615 staticpro (&Qfile_modes
);
5616 staticpro (&Qset_file_modes
);
5617 staticpro (&Qset_file_times
);
5618 staticpro (&Qfile_selinux_context
);
5619 staticpro (&Qset_file_selinux_context
);
5620 staticpro (&Qfile_newer_than_file_p
);
5621 staticpro (&Qinsert_file_contents
);
5622 staticpro (&Qwrite_region
);
5623 staticpro (&Qverify_visited_file_modtime
);
5624 staticpro (&Qset_visited_file_modtime
);
5625 staticpro (&Qauto_save_coding
);
5627 Qfile_name_history
= intern_c_string ("file-name-history");
5628 Fset (Qfile_name_history
, Qnil
);
5629 staticpro (&Qfile_name_history
);
5631 Qfile_error
= intern_c_string ("file-error");
5632 staticpro (&Qfile_error
);
5633 Qfile_already_exists
= intern_c_string ("file-already-exists");
5634 staticpro (&Qfile_already_exists
);
5635 Qfile_date_error
= intern_c_string ("file-date-error");
5636 staticpro (&Qfile_date_error
);
5637 Qexcl
= intern_c_string ("excl");
5641 Qfind_buffer_file_type
= intern_c_string ("find-buffer-file-type");
5642 staticpro (&Qfind_buffer_file_type
);
5645 DEFVAR_LISP ("file-name-coding-system", &Vfile_name_coding_system
,
5646 doc
: /* *Coding system for encoding file names.
5647 If it is nil, `default-file-name-coding-system' (which see) is used. */);
5648 Vfile_name_coding_system
= Qnil
;
5650 DEFVAR_LISP ("default-file-name-coding-system",
5651 &Vdefault_file_name_coding_system
,
5652 doc
: /* Default coding system for encoding file names.
5653 This variable is used only when `file-name-coding-system' is nil.
5655 This variable is set/changed by the command `set-language-environment'.
5656 User should not set this variable manually,
5657 instead use `file-name-coding-system' to get a constant encoding
5658 of file names regardless of the current language environment. */);
5659 Vdefault_file_name_coding_system
= Qnil
;
5661 Qformat_decode
= intern_c_string ("format-decode");
5662 staticpro (&Qformat_decode
);
5663 Qformat_annotate_function
= intern_c_string ("format-annotate-function");
5664 staticpro (&Qformat_annotate_function
);
5665 Qafter_insert_file_set_coding
= intern_c_string ("after-insert-file-set-coding");
5666 staticpro (&Qafter_insert_file_set_coding
);
5668 Qcar_less_than_car
= intern_c_string ("car-less-than-car");
5669 staticpro (&Qcar_less_than_car
);
5671 Fput (Qfile_error
, Qerror_conditions
,
5672 Fpurecopy (list2 (Qfile_error
, Qerror
)));
5673 Fput (Qfile_error
, Qerror_message
,
5674 make_pure_c_string ("File error"));
5676 Fput (Qfile_already_exists
, Qerror_conditions
,
5677 Fpurecopy (list3 (Qfile_already_exists
, Qfile_error
, Qerror
)));
5678 Fput (Qfile_already_exists
, Qerror_message
,
5679 make_pure_c_string ("File already exists"));
5681 Fput (Qfile_date_error
, Qerror_conditions
,
5682 Fpurecopy (list3 (Qfile_date_error
, Qfile_error
, Qerror
)));
5683 Fput (Qfile_date_error
, Qerror_message
,
5684 make_pure_c_string ("Cannot set file date"));
5686 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist
,
5687 doc
: /* *Alist of elements (REGEXP . HANDLER) for file names handled specially.
5688 If a file name matches REGEXP, then all I/O on that file is done by calling
5691 The first argument given to HANDLER is the name of the I/O primitive
5692 to be handled; the remaining arguments are the arguments that were
5693 passed to that primitive. For example, if you do
5694 (file-exists-p FILENAME)
5695 and FILENAME is handled by HANDLER, then HANDLER is called like this:
5696 (funcall HANDLER 'file-exists-p FILENAME)
5697 The function `find-file-name-handler' checks this list for a handler
5698 for its argument. */);
5699 Vfile_name_handler_alist
= Qnil
;
5701 DEFVAR_LISP ("set-auto-coding-function",
5702 &Vset_auto_coding_function
,
5703 doc
: /* If non-nil, a function to call to decide a coding system of file.
5704 Two arguments are passed to this function: the file name
5705 and the length of a file contents following the point.
5706 This function should return a coding system to decode the file contents.
5707 It should check the file name against `auto-coding-alist'.
5708 If no coding system is decided, it should check a coding system
5709 specified in the heading lines with the format:
5710 -*- ... coding: CODING-SYSTEM; ... -*-
5711 or local variable spec of the tailing lines with `coding:' tag. */);
5712 Vset_auto_coding_function
= Qnil
;
5714 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions
,
5715 doc
: /* A list of functions to be called at the end of `insert-file-contents'.
5716 Each is passed one argument, the number of characters inserted,
5717 with point at the start of the inserted text. Each function
5718 should leave point the same, and return the new character count.
5719 If `insert-file-contents' is intercepted by a handler from
5720 `file-name-handler-alist', that handler is responsible for calling the
5721 functions in `after-insert-file-functions' if appropriate. */);
5722 Vafter_insert_file_functions
= Qnil
;
5724 DEFVAR_LISP ("write-region-annotate-functions", &Vwrite_region_annotate_functions
,
5725 doc
: /* A list of functions to be called at the start of `write-region'.
5726 Each is passed two arguments, START and END as for `write-region'.
5727 These are usually two numbers but not always; see the documentation
5728 for `write-region'. The function should return a list of pairs
5729 of the form (POSITION . STRING), consisting of strings to be effectively
5730 inserted at the specified positions of the file being written (1 means to
5731 insert before the first byte written). The POSITIONs must be sorted into
5734 If there are several annotation functions, the lists returned by these
5735 functions are merged destructively. As each annotation function runs,
5736 the variable `write-region-annotations-so-far' contains a list of all
5737 annotations returned by previous annotation functions.
5739 An annotation function can return with a different buffer current.
5740 Doing so removes the annotations returned by previous functions, and
5741 resets START and END to `point-min' and `point-max' of the new buffer.
5743 After `write-region' completes, Emacs calls the function stored in
5744 `write-region-post-annotation-function', once for each buffer that was
5745 current when building the annotations (i.e., at least once), with that
5746 buffer current. */);
5747 Vwrite_region_annotate_functions
= Qnil
;
5748 staticpro (&Qwrite_region_annotate_functions
);
5749 Qwrite_region_annotate_functions
5750 = intern_c_string ("write-region-annotate-functions");
5752 DEFVAR_LISP ("write-region-post-annotation-function",
5753 &Vwrite_region_post_annotation_function
,
5754 doc
: /* Function to call after `write-region' completes.
5755 The function is called with no arguments. If one or more of the
5756 annotation functions in `write-region-annotate-functions' changed the
5757 current buffer, the function stored in this variable is called for
5758 each of those additional buffers as well, in addition to the original
5759 buffer. The relevant buffer is current during each function call. */);
5760 Vwrite_region_post_annotation_function
= Qnil
;
5761 staticpro (&Vwrite_region_annotation_buffers
);
5763 DEFVAR_LISP ("write-region-annotations-so-far",
5764 &Vwrite_region_annotations_so_far
,
5765 doc
: /* When an annotation function is called, this holds the previous annotations.
5766 These are the annotations made by other annotation functions
5767 that were already called. See also `write-region-annotate-functions'. */);
5768 Vwrite_region_annotations_so_far
= Qnil
;
5770 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers
,
5771 doc
: /* A list of file name handlers that temporarily should not be used.
5772 This applies only to the operation `inhibit-file-name-operation'. */);
5773 Vinhibit_file_name_handlers
= Qnil
;
5775 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation
,
5776 doc
: /* The operation for which `inhibit-file-name-handlers' is applicable. */);
5777 Vinhibit_file_name_operation
= Qnil
;
5779 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name
,
5780 doc
: /* File name in which we write a list of all auto save file names.
5781 This variable is initialized automatically from `auto-save-list-file-prefix'
5782 shortly after Emacs reads your `.emacs' file, if you have not yet given it
5783 a non-nil value. */);
5784 Vauto_save_list_file_name
= Qnil
;
5786 DEFVAR_LISP ("auto-save-visited-file-name", &Vauto_save_visited_file_name
,
5787 doc
: /* Non-nil says auto-save a buffer in the file it is visiting, when practical.
5788 Normally auto-save files are written under other names. */);
5789 Vauto_save_visited_file_name
= Qnil
;
5791 DEFVAR_LISP ("auto-save-include-big-deletions", &Vauto_save_include_big_deletions
,
5792 doc
: /* If non-nil, auto-save even if a large part of the text is deleted.
5793 If nil, deleting a substantial portion of the text disables auto-save
5794 in the buffer; this is the default behavior, because the auto-save
5795 file is usually more useful if it contains the deleted text. */);
5796 Vauto_save_include_big_deletions
= Qnil
;
5799 DEFVAR_BOOL ("write-region-inhibit-fsync", &write_region_inhibit_fsync
,
5800 doc
: /* *Non-nil means don't call fsync in `write-region'.
5801 This variable affects calls to `write-region' as well as save commands.
5802 A non-nil value may result in data loss! */);
5803 write_region_inhibit_fsync
= 0;
5806 DEFVAR_BOOL ("delete-by-moving-to-trash", &delete_by_moving_to_trash
,
5807 doc
: /* Specifies whether to use the system's trash can.
5808 When non-nil, certain file deletion commands use the function
5809 `move-file-to-trash' instead of deleting files outright.
5810 This includes interactive calls to `delete-file' and
5811 `delete-directory' and the Dired deletion commands. */);
5812 delete_by_moving_to_trash
= 0;
5813 Qdelete_by_moving_to_trash
= intern_c_string ("delete-by-moving-to-trash");
5814 Qmove_file_to_trash
= intern_c_string ("move-file-to-trash");
5815 staticpro (&Qmove_file_to_trash
);
5816 Qcopy_directory
= intern_c_string ("copy-directory");
5817 staticpro (&Qcopy_directory
);
5818 Qdelete_directory
= intern_c_string ("delete-directory");
5819 staticpro (&Qdelete_directory
);
5821 defsubr (&Sfind_file_name_handler
);
5822 defsubr (&Sfile_name_directory
);
5823 defsubr (&Sfile_name_nondirectory
);
5824 defsubr (&Sunhandled_file_name_directory
);
5825 defsubr (&Sfile_name_as_directory
);
5826 defsubr (&Sdirectory_file_name
);
5827 defsubr (&Smake_temp_name
);
5828 defsubr (&Sexpand_file_name
);
5829 defsubr (&Ssubstitute_in_file_name
);
5830 defsubr (&Scopy_file
);
5831 defsubr (&Smake_directory_internal
);
5832 defsubr (&Sdelete_directory_internal
);
5833 defsubr (&Sdelete_file
);
5834 defsubr (&Srename_file
);
5835 defsubr (&Sadd_name_to_file
);
5836 defsubr (&Smake_symbolic_link
);
5837 defsubr (&Sfile_name_absolute_p
);
5838 defsubr (&Sfile_exists_p
);
5839 defsubr (&Sfile_executable_p
);
5840 defsubr (&Sfile_readable_p
);
5841 defsubr (&Sfile_writable_p
);
5842 defsubr (&Saccess_file
);
5843 defsubr (&Sfile_symlink_p
);
5844 defsubr (&Sfile_directory_p
);
5845 defsubr (&Sfile_accessible_directory_p
);
5846 defsubr (&Sfile_regular_p
);
5847 defsubr (&Sfile_modes
);
5848 defsubr (&Sset_file_modes
);
5849 defsubr (&Sset_file_times
);
5850 defsubr (&Sfile_selinux_context
);
5851 defsubr (&Sset_file_selinux_context
);
5852 defsubr (&Sset_default_file_modes
);
5853 defsubr (&Sdefault_file_modes
);
5854 defsubr (&Sfile_newer_than_file_p
);
5855 defsubr (&Sinsert_file_contents
);
5856 defsubr (&Swrite_region
);
5857 defsubr (&Scar_less_than_car
);
5858 defsubr (&Sverify_visited_file_modtime
);
5859 defsubr (&Sclear_visited_file_modtime
);
5860 defsubr (&Svisited_file_modtime
);
5861 defsubr (&Sset_visited_file_modtime
);
5862 defsubr (&Sdo_auto_save
);
5863 defsubr (&Sset_buffer_auto_saved
);
5864 defsubr (&Sclear_buffer_auto_save_failure
);
5865 defsubr (&Srecent_auto_save_p
);
5867 defsubr (&Snext_read_file_uses_dialog_p
);
5870 defsubr (&Sunix_sync
);