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 eventually nil would
741 have to be returned anyway. */
742 report_file_error ("Cannot create temporary name for prefix",
743 Fcons (prefix
, Qnil
));
750 DEFUN ("make-temp-name", Fmake_temp_name
, Smake_temp_name
, 1, 1, 0,
751 doc
: /* Generate temporary file name (string) starting with PREFIX (a string).
752 The Emacs process number forms part of the result,
753 so there is no danger of generating a name being used by another process.
755 In addition, this function makes an attempt to choose a name
756 which has no existing file. To make this work,
757 PREFIX should be an absolute file name.
759 There is a race condition between calling `make-temp-name' and creating the
760 file which opens all kinds of security holes. For that reason, you should
761 probably use `make-temp-file' instead, except in three circumstances:
763 * If you are creating the file in the user's home directory.
764 * If you are creating a directory rather than an ordinary file.
765 * If you are taking special precautions as `make-temp-file' does. */)
768 return make_temp_name (prefix
, 0);
773 DEFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
774 doc
: /* Convert filename NAME to absolute, and canonicalize it.
775 Second arg DEFAULT-DIRECTORY is directory to start with if NAME is relative
776 \(does not start with slash or tilde); if DEFAULT-DIRECTORY is nil or missing,
777 the current buffer's value of `default-directory' is used.
778 NAME should be a string that is a valid file name for the underlying
780 File name components that are `.' are removed, and
781 so are file name components followed by `..', along with the `..' itself;
782 note that these simplifications are done without checking the resulting
783 file names in the file system.
784 Multiple consecutive slashes are collapsed into a single slash,
785 except at the beginning of the file name when they are significant (e.g.,
786 UNC file names on MS-Windows.)
787 An initial `~/' expands to your home directory.
788 An initial `~USER/' expands to USER's home directory.
789 See also the function `substitute-in-file-name'.
791 For technical reasons, this function can return correct but
792 non-intuitive results for the root directory; for instance,
793 \(expand-file-name ".." "/") returns "/..". For this reason, use
794 \(directory-file-name (file-name-directory dirname)) to traverse a
795 filesystem tree, not (expand-file-name ".." dirname). */)
796 (Lisp_Object name
, Lisp_Object default_directory
)
798 /* These point to SDATA and need to be careful with string-relocation
799 during GC (via DECODE_FILE). */
800 unsigned char *nm
, *newdir
;
801 /* This should only point to alloca'd data. */
802 unsigned char *target
;
808 int collapse_newdir
= 1;
812 Lisp_Object handler
, result
;
818 /* If the file name has special constructs in it,
819 call the corresponding file handler. */
820 handler
= Ffind_file_name_handler (name
, Qexpand_file_name
);
822 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
824 /* Use the buffer's default-directory if DEFAULT_DIRECTORY is omitted. */
825 if (NILP (default_directory
))
826 default_directory
= current_buffer
->directory
;
827 if (! STRINGP (default_directory
))
830 /* "/" is not considered a root directory on DOS_NT, so using "/"
831 here causes an infinite recursion in, e.g., the following:
833 (let (default-directory)
834 (expand-file-name "a"))
836 To avoid this, we set default_directory to the root of the
838 default_directory
= build_string (emacs_root_dir ());
840 default_directory
= build_string ("/");
844 if (!NILP (default_directory
))
846 handler
= Ffind_file_name_handler (default_directory
, Qexpand_file_name
);
848 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
852 unsigned char *o
= SDATA (default_directory
);
854 /* Make sure DEFAULT_DIRECTORY is properly expanded.
855 It would be better to do this down below where we actually use
856 default_directory. Unfortunately, calling Fexpand_file_name recursively
857 could invoke GC, and the strings might be relocated. This would
858 be annoying because we have pointers into strings lying around
859 that would need adjusting, and people would add new pointers to
860 the code and forget to adjust them, resulting in intermittent bugs.
861 Putting this call here avoids all that crud.
863 The EQ test avoids infinite recursion. */
864 if (! NILP (default_directory
) && !EQ (default_directory
, name
)
865 /* Save time in some common cases - as long as default_directory
866 is not relative, it can be canonicalized with name below (if it
867 is needed at all) without requiring it to be expanded now. */
869 /* Detect MSDOS file names with drive specifiers. */
870 && ! (IS_DRIVE (o
[0]) && IS_DEVICE_SEP (o
[1])
871 && IS_DIRECTORY_SEP (o
[2]))
873 /* Detect Windows file names in UNC format. */
874 && ! (IS_DIRECTORY_SEP (o
[0]) && IS_DIRECTORY_SEP (o
[1]))
876 #else /* not DOS_NT */
877 /* Detect Unix absolute file names (/... alone is not absolute on
879 && ! (IS_DIRECTORY_SEP (o
[0]))
880 #endif /* not DOS_NT */
886 default_directory
= Fexpand_file_name (default_directory
, Qnil
);
890 name
= FILE_SYSTEM_CASE (name
);
891 multibyte
= STRING_MULTIBYTE (name
);
892 if (multibyte
!= STRING_MULTIBYTE (default_directory
))
895 default_directory
= string_to_multibyte (default_directory
);
898 name
= string_to_multibyte (name
);
903 /* Make a local copy of nm[] to protect it from GC in DECODE_FILE below. */
904 nm
= (unsigned char *) alloca (SBYTES (name
) + 1);
905 memcpy (nm
, SDATA (name
), SBYTES (name
) + 1);
908 /* Note if special escape prefix is present, but remove for now. */
909 if (nm
[0] == '/' && nm
[1] == ':')
915 /* Find and remove drive specifier if present; this makes nm absolute
916 even if the rest of the name appears to be relative. Only look for
917 drive specifier at the beginning. */
918 if (IS_DRIVE (nm
[0]) && IS_DEVICE_SEP (nm
[1]))
925 /* If we see "c://somedir", we want to strip the first slash after the
926 colon when stripping the drive letter. Otherwise, this expands to
928 if (drive
&& IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
931 /* Discard any previous drive specifier if nm is now in UNC format. */
932 if (IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
936 #endif /* WINDOWSNT */
939 /* If nm is absolute, look for `/./' or `/../' or `//''sequences; if
940 none are found, we can probably return right away. We will avoid
941 allocating a new string if name is already fully expanded. */
943 IS_DIRECTORY_SEP (nm
[0])
945 && drive
&& !is_escaped
948 && (drive
|| IS_DIRECTORY_SEP (nm
[1])) && !is_escaped
952 /* If it turns out that the filename we want to return is just a
953 suffix of FILENAME, we don't need to go through and edit
954 things; we just need to construct a new string using data
955 starting at the middle of FILENAME. If we set lose to a
956 non-zero value, that means we've discovered that we can't do
959 unsigned char *p
= nm
;
963 /* Since we know the name is absolute, we can assume that each
964 element starts with a "/". */
966 /* "." and ".." are hairy. */
967 if (IS_DIRECTORY_SEP (p
[0])
969 && (IS_DIRECTORY_SEP (p
[2])
971 || (p
[2] == '.' && (IS_DIRECTORY_SEP (p
[3])
974 /* We want to replace multiple `/' in a row with a single
977 && IS_DIRECTORY_SEP (p
[0])
978 && IS_DIRECTORY_SEP (p
[1]))
985 /* Make sure directories are all separated with /, but
986 avoid allocation of a new string when not required. */
987 dostounix_filename (nm
);
989 if (IS_DIRECTORY_SEP (nm
[1]))
991 if (strcmp (nm
, SDATA (name
)) != 0)
992 name
= make_specified_string (nm
, -1, strlen (nm
), multibyte
);
996 /* drive must be set, so this is okay */
997 if (strcmp (nm
- 2, SDATA (name
)) != 0)
1001 name
= make_specified_string (nm
, -1, p
- nm
, multibyte
);
1002 temp
[0] = DRIVE_LETTER (drive
);
1003 name
= concat2 (build_string (temp
), name
);
1006 #else /* not DOS_NT */
1007 if (strcmp (nm
, SDATA (name
)) == 0)
1009 return make_specified_string (nm
, -1, strlen (nm
), multibyte
);
1010 #endif /* not DOS_NT */
1014 /* At this point, nm might or might not be an absolute file name. We
1015 need to expand ~ or ~user if present, otherwise prefix nm with
1016 default_directory if nm is not absolute, and finally collapse /./
1017 and /foo/../ sequences.
1019 We set newdir to be the appropriate prefix if one is needed:
1020 - the relevant user directory if nm starts with ~ or ~user
1021 - the specified drive's working dir (DOS/NT only) if nm does not
1023 - the value of default_directory.
1025 Note that these prefixes are not guaranteed to be absolute (except
1026 for the working dir of a drive). Therefore, to ensure we always
1027 return an absolute name, if the final prefix is not absolute we
1028 append it to the current working directory. */
1032 if (nm
[0] == '~') /* prefix ~ */
1034 if (IS_DIRECTORY_SEP (nm
[1])
1035 || nm
[1] == 0) /* ~ by itself */
1039 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1040 newdir
= (unsigned char *) "";
1042 /* egetenv may return a unibyte string, which will bite us since
1043 we expect the directory to be multibyte. */
1044 tem
= build_string (newdir
);
1045 if (!STRING_MULTIBYTE (tem
))
1047 hdir
= DECODE_FILE (tem
);
1048 newdir
= SDATA (hdir
);
1051 collapse_newdir
= 0;
1054 else /* ~user/filename */
1056 unsigned char *o
, *p
;
1057 for (p
= nm
; *p
&& (!IS_DIRECTORY_SEP (*p
)); p
++);
1058 o
= alloca (p
- nm
+ 1);
1059 memcpy (o
, nm
, p
- nm
);
1063 pw
= (struct passwd
*) getpwnam (o
+ 1);
1067 newdir
= (unsigned char *) pw
-> pw_dir
;
1070 collapse_newdir
= 0;
1074 /* If we don't find a user of that name, leave the name
1075 unchanged; don't move nm forward to p. */
1080 /* On DOS and Windows, nm is absolute if a drive name was specified;
1081 use the drive's current directory as the prefix if needed. */
1082 if (!newdir
&& drive
)
1084 /* Get default directory if needed to make nm absolute. */
1085 if (!IS_DIRECTORY_SEP (nm
[0]))
1087 newdir
= alloca (MAXPATHLEN
+ 1);
1088 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1093 /* Either nm starts with /, or drive isn't mounted. */
1094 newdir
= alloca (4);
1095 newdir
[0] = DRIVE_LETTER (drive
);
1103 /* Finally, if no prefix has been specified and nm is not absolute,
1104 then it must be expanded relative to default_directory. */
1108 /* /... alone is not absolute on DOS and Windows. */
1109 && !IS_DIRECTORY_SEP (nm
[0])
1112 && !(IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1116 newdir
= SDATA (default_directory
);
1118 /* Note if special escape prefix is present, but remove for now. */
1119 if (newdir
[0] == '/' && newdir
[1] == ':')
1130 /* First ensure newdir is an absolute name. */
1132 /* Detect MSDOS file names with drive specifiers. */
1133 ! (IS_DRIVE (newdir
[0])
1134 && IS_DEVICE_SEP (newdir
[1]) && IS_DIRECTORY_SEP (newdir
[2]))
1136 /* Detect Windows file names in UNC format. */
1137 && ! (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1141 /* Effectively, let newdir be (expand-file-name newdir cwd).
1142 Because of the admonition against calling expand-file-name
1143 when we have pointers into lisp strings, we accomplish this
1144 indirectly by prepending newdir to nm if necessary, and using
1145 cwd (or the wd of newdir's drive) as the new newdir. */
1147 if (IS_DRIVE (newdir
[0]) && IS_DEVICE_SEP (newdir
[1]))
1152 if (!IS_DIRECTORY_SEP (nm
[0]))
1154 char * tmp
= alloca (strlen (newdir
) + strlen (nm
) + 2);
1155 file_name_as_directory (tmp
, newdir
);
1159 newdir
= alloca (MAXPATHLEN
+ 1);
1162 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1169 /* Strip off drive name from prefix, if present. */
1170 if (IS_DRIVE (newdir
[0]) && IS_DEVICE_SEP (newdir
[1]))
1176 /* Keep only a prefix from newdir if nm starts with slash
1177 (//server/share for UNC, nothing otherwise). */
1178 if (IS_DIRECTORY_SEP (nm
[0]) && collapse_newdir
)
1181 if (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1184 newdir
= strcpy (alloca (strlen (newdir
) + 1), newdir
);
1186 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1188 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1200 /* Get rid of any slash at the end of newdir, unless newdir is
1201 just / or // (an incomplete UNC name). */
1202 length
= strlen (newdir
);
1203 if (length
> 1 && IS_DIRECTORY_SEP (newdir
[length
- 1])
1205 && !(length
== 2 && IS_DIRECTORY_SEP (newdir
[0]))
1209 unsigned char *temp
= (unsigned char *) alloca (length
);
1210 memcpy (temp
, newdir
, length
- 1);
1211 temp
[length
- 1] = 0;
1219 /* Now concatenate the directory and name to new space in the stack frame */
1220 tlen
+= strlen (nm
) + 1;
1222 /* Reserve space for drive specifier and escape prefix, since either
1223 or both may need to be inserted. (The Microsoft x86 compiler
1224 produces incorrect code if the following two lines are combined.) */
1225 target
= (unsigned char *) alloca (tlen
+ 4);
1227 #else /* not DOS_NT */
1228 target
= (unsigned char *) alloca (tlen
);
1229 #endif /* not DOS_NT */
1234 if (nm
[0] == 0 || IS_DIRECTORY_SEP (nm
[0]))
1237 /* If newdir is effectively "C:/", then the drive letter will have
1238 been stripped and newdir will be "/". Concatenating with an
1239 absolute directory in nm produces "//", which will then be
1240 incorrectly treated as a network share. Ignore newdir in
1241 this case (keeping the drive letter). */
1242 if (!(drive
&& nm
[0] && IS_DIRECTORY_SEP (newdir
[0])
1243 && newdir
[1] == '\0'))
1245 strcpy (target
, newdir
);
1248 file_name_as_directory (target
, newdir
);
1251 strcat (target
, nm
);
1253 /* Now canonicalize by removing `//', `/.' and `/foo/..' if they
1256 unsigned char *p
= target
;
1257 unsigned char *o
= target
;
1261 if (!IS_DIRECTORY_SEP (*p
))
1265 else if (p
[1] == '.'
1266 && (IS_DIRECTORY_SEP (p
[2])
1269 /* If "/." is the entire filename, keep the "/". Otherwise,
1270 just delete the whole "/.". */
1271 if (o
== target
&& p
[2] == '\0')
1275 else if (p
[1] == '.' && p
[2] == '.'
1276 /* `/../' is the "superroot" on certain file systems.
1277 Turned off on DOS_NT systems because they have no
1278 "superroot" and because this causes us to produce
1279 file names like "d:/../foo" which fail file-related
1280 functions of the underlying OS. (To reproduce, try a
1281 long series of "../../" in default_directory, longer
1282 than the number of levels from the root.) */
1286 && (IS_DIRECTORY_SEP (p
[3]) || p
[3] == 0))
1289 unsigned char *prev_o
= o
;
1291 while (o
!= target
&& (--o
) && !IS_DIRECTORY_SEP (*o
))
1294 /* Don't go below server level in UNC filenames. */
1295 if (o
== target
+ 1 && IS_DIRECTORY_SEP (*o
)
1296 && IS_DIRECTORY_SEP (*target
))
1300 /* Keep initial / only if this is the whole name. */
1301 if (o
== target
&& IS_ANY_SEP (*o
) && p
[3] == 0)
1305 else if (p
> target
&& IS_DIRECTORY_SEP (p
[1]))
1306 /* Collapse multiple `/' in a row. */
1315 /* At last, set drive name. */
1317 /* Except for network file name. */
1318 if (!(IS_DIRECTORY_SEP (target
[0]) && IS_DIRECTORY_SEP (target
[1])))
1319 #endif /* WINDOWSNT */
1321 if (!drive
) abort ();
1323 target
[0] = DRIVE_LETTER (drive
);
1326 /* Reinsert the escape prefix if required. */
1333 dostounix_filename (target
);
1336 result
= make_specified_string (target
, -1, o
- target
, multibyte
);
1339 /* Again look to see if the file name has special constructs in it
1340 and perhaps call the corresponding file handler. This is needed
1341 for filenames such as "/foo/../user@host:/bar/../baz". Expanding
1342 the ".." component gives us "/user@host:/bar/../baz" which needs
1343 to be expanded again. */
1344 handler
= Ffind_file_name_handler (result
, Qexpand_file_name
);
1345 if (!NILP (handler
))
1346 return call3 (handler
, Qexpand_file_name
, result
, default_directory
);
1352 /* PLEASE DO NOT DELETE THIS COMMENTED-OUT VERSION!
1353 This is the old version of expand-file-name, before it was thoroughly
1354 rewritten for Emacs 10.31. We leave this version here commented-out,
1355 because the code is very complex and likely to have subtle bugs. If
1356 bugs _are_ found, it might be of interest to look at the old code and
1357 see what did it do in the relevant situation.
1359 Don't remove this code: it's true that it will be accessible
1360 from the repository, but a few years from deletion, people will
1361 forget it is there. */
1363 /* Changed this DEFUN to a DEAFUN, so as not to confuse `make-docfile'. */
1364 DEAFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
1365 "Convert FILENAME to absolute, and canonicalize it.\n\
1366 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
1367 \(does not start with slash); if DEFAULT is nil or missing,\n\
1368 the current buffer's value of default-directory is used.\n\
1369 Filenames containing `.' or `..' as components are simplified;\n\
1370 initial `~/' expands to your home directory.\n\
1371 See also the function `substitute-in-file-name'.")
1373 Lisp_Object name
, defalt
;
1377 register unsigned char *newdir
, *p
, *o
;
1379 unsigned char *target
;
1383 CHECK_STRING (name
);
1386 /* If nm is absolute, flush ...// and detect /./ and /../.
1387 If no /./ or /../ we can return right away. */
1394 if (p
[0] == '/' && p
[1] == '/'
1397 if (p
[0] == '/' && p
[1] == '~')
1398 nm
= p
+ 1, lose
= 1;
1399 if (p
[0] == '/' && p
[1] == '.'
1400 && (p
[2] == '/' || p
[2] == 0
1401 || (p
[2] == '.' && (p
[3] == '/' || p
[3] == 0))))
1407 if (nm
== SDATA (name
))
1409 return build_string (nm
);
1413 /* Now determine directory to start with and put it in NEWDIR */
1417 if (nm
[0] == '~') /* prefix ~ */
1418 if (nm
[1] == '/' || nm
[1] == 0)/* ~/filename */
1420 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1421 newdir
= (unsigned char *) "";
1424 else /* ~user/filename */
1426 /* Get past ~ to user */
1427 unsigned char *user
= nm
+ 1;
1428 /* Find end of name. */
1429 unsigned char *ptr
= (unsigned char *) strchr (user
, '/');
1430 int len
= ptr
? ptr
- user
: strlen (user
);
1431 /* Copy the user name into temp storage. */
1432 o
= (unsigned char *) alloca (len
+ 1);
1433 memcpy (o
, user
, len
);
1436 /* Look up the user name. */
1438 pw
= (struct passwd
*) getpwnam (o
+ 1);
1441 error ("\"%s\" isn't a registered user", o
+ 1);
1443 newdir
= (unsigned char *) pw
->pw_dir
;
1445 /* Discard the user name from NM. */
1449 if (nm
[0] != '/' && !newdir
)
1452 defalt
= current_buffer
->directory
;
1453 CHECK_STRING (defalt
);
1454 newdir
= SDATA (defalt
);
1457 /* Now concatenate the directory and name to new space in the stack frame */
1459 tlen
= (newdir
? strlen (newdir
) + 1 : 0) + strlen (nm
) + 1;
1460 target
= (unsigned char *) alloca (tlen
);
1465 if (nm
[0] == 0 || nm
[0] == '/')
1466 strcpy (target
, newdir
);
1468 file_name_as_directory (target
, newdir
);
1471 strcat (target
, nm
);
1473 /* Now canonicalize by removing /. and /foo/.. if they appear */
1484 else if (!strncmp (p
, "//", 2)
1490 else if (p
[0] == '/' && p
[1] == '.'
1491 && (p
[2] == '/' || p
[2] == 0))
1493 else if (!strncmp (p
, "/..", 3)
1494 /* `/../' is the "superroot" on certain file systems. */
1496 && (p
[3] == '/' || p
[3] == 0))
1498 while (o
!= target
&& *--o
!= '/')
1500 if (o
== target
&& *o
== '/')
1510 return make_string (target
, o
- target
);
1514 /* If /~ or // appears, discard everything through first slash. */
1516 file_name_absolute_p (const unsigned char *filename
)
1519 (IS_DIRECTORY_SEP (*filename
) || *filename
== '~'
1521 || (IS_DRIVE (*filename
) && IS_DEVICE_SEP (filename
[1])
1522 && IS_DIRECTORY_SEP (filename
[2]))
1527 static unsigned char *
1528 search_embedded_absfilename (unsigned char *nm
, unsigned char *endp
)
1530 unsigned char *p
, *s
;
1532 for (p
= nm
+ 1; p
< endp
; p
++)
1535 || IS_DIRECTORY_SEP (p
[-1]))
1536 && file_name_absolute_p (p
)
1537 #if defined (WINDOWSNT) || defined(CYGWIN)
1538 /* // at start of file name is meaningful in Apollo,
1539 WindowsNT and Cygwin systems. */
1540 && !(IS_DIRECTORY_SEP (p
[0]) && p
- 1 == nm
)
1541 #endif /* not (WINDOWSNT || CYGWIN) */
1544 for (s
= p
; *s
&& (!IS_DIRECTORY_SEP (*s
)); s
++);
1545 if (p
[0] == '~' && s
> p
+ 1) /* we've got "/~something/" */
1547 unsigned char *o
= alloca (s
- p
+ 1);
1549 memcpy (o
, p
, s
- p
);
1552 /* If we have ~user and `user' exists, discard
1553 everything up to ~. But if `user' does not exist, leave
1554 ~user alone, it might be a literal file name. */
1556 pw
= getpwnam (o
+ 1);
1568 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name
,
1569 Ssubstitute_in_file_name
, 1, 1, 0,
1570 doc
: /* Substitute environment variables referred to in FILENAME.
1571 `$FOO' where FOO is an environment variable name means to substitute
1572 the value of that variable. The variable name should be terminated
1573 with a character not a letter, digit or underscore; otherwise, enclose
1574 the entire variable name in braces.
1576 If `/~' appears, all of FILENAME through that `/' is discarded.
1577 If `//' appears, everything up to and including the first of
1578 those `/' is discarded. */)
1579 (Lisp_Object filename
)
1583 register unsigned char *s
, *p
, *o
, *x
, *endp
;
1584 unsigned char *target
= NULL
;
1586 int substituted
= 0;
1589 Lisp_Object handler
;
1591 CHECK_STRING (filename
);
1593 multibyte
= STRING_MULTIBYTE (filename
);
1595 /* If the file name has special constructs in it,
1596 call the corresponding file handler. */
1597 handler
= Ffind_file_name_handler (filename
, Qsubstitute_in_file_name
);
1598 if (!NILP (handler
))
1599 return call2 (handler
, Qsubstitute_in_file_name
, filename
);
1601 /* Always work on a copy of the string, in case GC happens during
1602 decode of environment variables, causing the original Lisp_String
1603 data to be relocated. */
1604 nm
= (unsigned char *) alloca (SBYTES (filename
) + 1);
1605 memcpy (nm
, SDATA (filename
), SBYTES (filename
) + 1);
1608 dostounix_filename (nm
);
1609 substituted
= (strcmp (nm
, SDATA (filename
)) != 0);
1611 endp
= nm
+ SBYTES (filename
);
1613 /* If /~ or // appears, discard everything through first slash. */
1614 p
= search_embedded_absfilename (nm
, endp
);
1616 /* Start over with the new string, so we check the file-name-handler
1617 again. Important with filenames like "/home/foo//:/hello///there"
1618 which whould substitute to "/:/hello///there" rather than "/there". */
1619 return Fsubstitute_in_file_name
1620 (make_specified_string (p
, -1, endp
- p
, multibyte
));
1622 /* See if any variables are substituted into the string
1623 and find the total length of their values in `total' */
1625 for (p
= nm
; p
!= endp
;)
1635 /* "$$" means a single "$" */
1644 while (p
!= endp
&& *p
!= '}') p
++;
1645 if (*p
!= '}') goto missingclose
;
1651 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1655 /* Copy out the variable name */
1656 target
= (unsigned char *) alloca (s
- o
+ 1);
1657 strncpy (target
, o
, s
- o
);
1660 strupr (target
); /* $home == $HOME etc. */
1663 /* Get variable value */
1664 o
= (unsigned char *) egetenv (target
);
1667 /* Don't try to guess a maximum length - UTF8 can use up to
1668 four bytes per character. This code is unlikely to run
1669 in a situation that requires performance, so decoding the
1670 env variables twice should be acceptable. Note that
1671 decoding may cause a garbage collect. */
1672 Lisp_Object orig
, decoded
;
1673 orig
= make_unibyte_string (o
, strlen (o
));
1674 decoded
= DECODE_FILE (orig
);
1675 total
+= SBYTES (decoded
);
1685 /* If substitution required, recopy the string and do it */
1686 /* Make space in stack frame for the new copy */
1687 xnm
= (unsigned char *) alloca (SBYTES (filename
) + total
+ 1);
1690 /* Copy the rest of the name through, replacing $ constructs with values */
1707 while (p
!= endp
&& *p
!= '}') p
++;
1708 if (*p
!= '}') goto missingclose
;
1714 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1718 /* Copy out the variable name */
1719 target
= (unsigned char *) alloca (s
- o
+ 1);
1720 strncpy (target
, o
, s
- o
);
1723 strupr (target
); /* $home == $HOME etc. */
1726 /* Get variable value */
1727 o
= (unsigned char *) egetenv (target
);
1731 strcpy (x
, target
); x
+= strlen (target
);
1735 Lisp_Object orig
, decoded
;
1736 int orig_length
, decoded_length
;
1737 orig_length
= strlen (o
);
1738 orig
= make_unibyte_string (o
, orig_length
);
1739 decoded
= DECODE_FILE (orig
);
1740 decoded_length
= SBYTES (decoded
);
1741 strncpy (x
, SDATA (decoded
), decoded_length
);
1742 x
+= decoded_length
;
1744 /* If environment variable needed decoding, return value
1745 needs to be multibyte. */
1746 if (decoded_length
!= orig_length
1747 || strncmp (SDATA (decoded
), o
, orig_length
))
1754 /* If /~ or // appears, discard everything through first slash. */
1755 while ((p
= search_embedded_absfilename (xnm
, x
)))
1756 /* This time we do not start over because we've already expanded envvars
1757 and replaced $$ with $. Maybe we should start over as well, but we'd
1758 need to quote some $ to $$ first. */
1761 return make_specified_string (xnm
, -1, x
- xnm
, multibyte
);
1764 error ("Bad format environment-variable substitution");
1766 error ("Missing \"}\" in environment-variable substitution");
1768 error ("Substituting nonexistent environment variable \"%s\"", target
);
1774 /* A slightly faster and more convenient way to get
1775 (directory-file-name (expand-file-name FOO)). */
1778 expand_and_dir_to_file (Lisp_Object filename
, Lisp_Object defdir
)
1780 register Lisp_Object absname
;
1782 absname
= Fexpand_file_name (filename
, defdir
);
1784 /* Remove final slash, if any (unless this is the root dir).
1785 stat behaves differently depending! */
1786 if (SCHARS (absname
) > 1
1787 && IS_DIRECTORY_SEP (SREF (absname
, SBYTES (absname
) - 1))
1788 && !IS_DEVICE_SEP (SREF (absname
, SBYTES (absname
)-2)))
1789 /* We cannot take shortcuts; they might be wrong for magic file names. */
1790 absname
= Fdirectory_file_name (absname
);
1794 /* Signal an error if the file ABSNAME already exists.
1795 If INTERACTIVE is nonzero, ask the user whether to proceed,
1796 and bypass the error if the user says to go ahead.
1797 QUERYSTRING is a name for the action that is being considered
1800 *STATPTR is used to store the stat information if the file exists.
1801 If the file does not exist, STATPTR->st_mode is set to 0.
1802 If STATPTR is null, we don't store into it.
1804 If QUICK is nonzero, we ask for y or n, not yes or no. */
1807 barf_or_query_if_file_exists (Lisp_Object absname
, const unsigned char *querystring
, int interactive
, struct stat
*statptr
, int quick
)
1809 register Lisp_Object tem
, encoded_filename
;
1810 struct stat statbuf
;
1811 struct gcpro gcpro1
;
1813 encoded_filename
= ENCODE_FILE (absname
);
1815 /* stat is a good way to tell whether the file exists,
1816 regardless of what access permissions it has. */
1817 if (lstat (SDATA (encoded_filename
), &statbuf
) >= 0)
1820 xsignal2 (Qfile_already_exists
,
1821 build_string ("File already exists"), absname
);
1823 tem
= format2 ("File %s already exists; %s anyway? ",
1824 absname
, build_string (querystring
));
1826 tem
= call1 (intern ("y-or-n-p"), tem
);
1828 tem
= do_yes_or_no_p (tem
);
1831 xsignal2 (Qfile_already_exists
,
1832 build_string ("File already exists"), absname
);
1839 statptr
->st_mode
= 0;
1844 DEFUN ("copy-file", Fcopy_file
, Scopy_file
, 2, 6,
1845 "fCopy file: \nGCopy %s to file: \np\nP",
1846 doc
: /* Copy FILE to NEWNAME. Both args must be strings.
1847 If NEWNAME names a directory, copy FILE there.
1849 This function always sets the file modes of the output file to match
1852 The optional third argument OK-IF-ALREADY-EXISTS specifies what to do
1853 if file NEWNAME already exists. If OK-IF-ALREADY-EXISTS is nil, we
1854 signal a `file-already-exists' error without overwriting. If
1855 OK-IF-ALREADY-EXISTS is a number, we request confirmation from the user
1856 about overwriting; this is what happens in interactive use with M-x.
1857 Any other value for OK-IF-ALREADY-EXISTS means to overwrite the
1860 Fourth arg KEEP-TIME non-nil means give the output file the same
1861 last-modified time as the old one. (This works on only some systems.)
1863 A prefix arg makes KEEP-TIME non-nil.
1865 If PRESERVE-UID-GID is non-nil, we try to transfer the
1866 uid and gid of FILE to NEWNAME.
1868 If PRESERVE-SELINUX-CONTEXT is non-nil and SELinux is enabled
1869 on the system, we copy the SELinux context of FILE to NEWNAME. */)
1870 (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
)
1873 char buf
[16 * 1024];
1874 struct stat st
, out_st
;
1875 Lisp_Object handler
;
1876 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1877 int count
= SPECPDL_INDEX ();
1878 int input_file_statable_p
;
1879 Lisp_Object encoded_file
, encoded_newname
;
1881 security_context_t con
;
1882 int fail
, conlength
= 0;
1885 encoded_file
= encoded_newname
= Qnil
;
1886 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
1887 CHECK_STRING (file
);
1888 CHECK_STRING (newname
);
1890 if (!NILP (Ffile_directory_p (newname
)))
1891 newname
= Fexpand_file_name (Ffile_name_nondirectory (file
), newname
);
1893 newname
= Fexpand_file_name (newname
, Qnil
);
1895 file
= Fexpand_file_name (file
, Qnil
);
1897 /* If the input file name has special constructs in it,
1898 call the corresponding file handler. */
1899 handler
= Ffind_file_name_handler (file
, Qcopy_file
);
1900 /* Likewise for output file name. */
1902 handler
= Ffind_file_name_handler (newname
, Qcopy_file
);
1903 if (!NILP (handler
))
1904 RETURN_UNGCPRO (call7 (handler
, Qcopy_file
, file
, newname
,
1905 ok_if_already_exists
, keep_time
, preserve_uid_gid
,
1906 preserve_selinux_context
));
1908 encoded_file
= ENCODE_FILE (file
);
1909 encoded_newname
= ENCODE_FILE (newname
);
1911 if (NILP (ok_if_already_exists
)
1912 || INTEGERP (ok_if_already_exists
))
1913 barf_or_query_if_file_exists (newname
, "copy to it",
1914 INTEGERP (ok_if_already_exists
), &out_st
, 0);
1915 else if (stat (SDATA (encoded_newname
), &out_st
) < 0)
1919 if (!CopyFile (SDATA (encoded_file
),
1920 SDATA (encoded_newname
),
1922 report_file_error ("Copying file", Fcons (file
, Fcons (newname
, Qnil
)));
1923 /* CopyFile retains the timestamp by default. */
1924 else if (NILP (keep_time
))
1930 EMACS_GET_TIME (now
);
1931 filename
= SDATA (encoded_newname
);
1933 /* Ensure file is writable while its modified time is set. */
1934 attributes
= GetFileAttributes (filename
);
1935 SetFileAttributes (filename
, attributes
& ~FILE_ATTRIBUTE_READONLY
);
1936 if (set_file_times (filename
, now
, now
))
1938 /* Restore original attributes. */
1939 SetFileAttributes (filename
, attributes
);
1940 xsignal2 (Qfile_date_error
,
1941 build_string ("Cannot set file date"), newname
);
1943 /* Restore original attributes. */
1944 SetFileAttributes (filename
, attributes
);
1946 #else /* not WINDOWSNT */
1948 ifd
= emacs_open (SDATA (encoded_file
), O_RDONLY
, 0);
1952 report_file_error ("Opening input file", Fcons (file
, Qnil
));
1954 record_unwind_protect (close_file_unwind
, make_number (ifd
));
1956 /* We can only copy regular files and symbolic links. Other files are not
1958 input_file_statable_p
= (fstat (ifd
, &st
) >= 0);
1961 if (!NILP (preserve_selinux_context
) && is_selinux_enabled ())
1963 conlength
= fgetfilecon (ifd
, &con
);
1964 if (conlength
== -1)
1965 report_file_error ("Doing fgetfilecon", Fcons (file
, Qnil
));
1969 if (out_st
.st_mode
!= 0
1970 && st
.st_dev
== out_st
.st_dev
&& st
.st_ino
== out_st
.st_ino
)
1973 report_file_error ("Input and output files are the same",
1974 Fcons (file
, Fcons (newname
, Qnil
)));
1977 #if defined (S_ISREG) && defined (S_ISLNK)
1978 if (input_file_statable_p
)
1980 if (!(S_ISREG (st
.st_mode
)) && !(S_ISLNK (st
.st_mode
)))
1982 #if defined (EISDIR)
1983 /* Get a better looking error message. */
1986 report_file_error ("Non-regular file", Fcons (file
, Qnil
));
1989 #endif /* S_ISREG && S_ISLNK */
1992 /* System's default file type was set to binary by _fmode in emacs.c. */
1993 ofd
= emacs_open (SDATA (encoded_newname
),
1994 O_WRONLY
| O_TRUNC
| O_CREAT
1995 | (NILP (ok_if_already_exists
) ? O_EXCL
: 0),
1996 S_IREAD
| S_IWRITE
);
1997 #else /* not MSDOS */
1998 ofd
= emacs_open (SDATA (encoded_newname
),
1999 O_WRONLY
| O_TRUNC
| O_CREAT
2000 | (NILP (ok_if_already_exists
) ? O_EXCL
: 0),
2002 #endif /* not MSDOS */
2004 report_file_error ("Opening output file", Fcons (newname
, Qnil
));
2006 record_unwind_protect (close_file_unwind
, make_number (ofd
));
2010 while ((n
= emacs_read (ifd
, buf
, sizeof buf
)) > 0)
2011 if (emacs_write (ofd
, buf
, n
) != n
)
2012 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2016 /* Preserve the original file modes, and if requested, also its
2018 if (input_file_statable_p
)
2020 if (! NILP (preserve_uid_gid
))
2021 fchown (ofd
, st
.st_uid
, st
.st_gid
);
2022 fchmod (ofd
, st
.st_mode
& 07777);
2024 #endif /* not MSDOS */
2029 /* Set the modified context back to the file. */
2030 fail
= fsetfilecon (ofd
, con
);
2032 report_file_error ("Doing fsetfilecon", Fcons (newname
, Qnil
));
2038 /* Closing the output clobbers the file times on some systems. */
2039 if (emacs_close (ofd
) < 0)
2040 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2042 if (input_file_statable_p
)
2044 if (!NILP (keep_time
))
2046 EMACS_TIME atime
, mtime
;
2047 EMACS_SET_SECS_USECS (atime
, st
.st_atime
, 0);
2048 EMACS_SET_SECS_USECS (mtime
, st
.st_mtime
, 0);
2049 if (set_file_times (SDATA (encoded_newname
),
2051 xsignal2 (Qfile_date_error
,
2052 build_string ("Cannot set file date"), newname
);
2059 if (input_file_statable_p
)
2061 /* In DJGPP v2.0 and later, fstat usually returns true file mode bits,
2062 and if it can't, it tells so. Otherwise, under MSDOS we usually
2063 get only the READ bit, which will make the copied file read-only,
2064 so it's better not to chmod at all. */
2065 if ((_djstat_flags
& _STFAIL_WRITEBIT
) == 0)
2066 chmod (SDATA (encoded_newname
), st
.st_mode
& 07777);
2069 #endif /* not WINDOWSNT */
2071 /* Discard the unwind protects. */
2072 specpdl_ptr
= specpdl
+ count
;
2078 DEFUN ("make-directory-internal", Fmake_directory_internal
,
2079 Smake_directory_internal
, 1, 1, 0,
2080 doc
: /* Create a new directory named DIRECTORY. */)
2081 (Lisp_Object directory
)
2083 const unsigned char *dir
;
2084 Lisp_Object handler
;
2085 Lisp_Object encoded_dir
;
2087 CHECK_STRING (directory
);
2088 directory
= Fexpand_file_name (directory
, Qnil
);
2090 handler
= Ffind_file_name_handler (directory
, Qmake_directory_internal
);
2091 if (!NILP (handler
))
2092 return call2 (handler
, Qmake_directory_internal
, directory
);
2094 encoded_dir
= ENCODE_FILE (directory
);
2096 dir
= SDATA (encoded_dir
);
2099 if (mkdir (dir
) != 0)
2101 if (mkdir (dir
, 0777) != 0)
2103 report_file_error ("Creating directory", list1 (directory
));
2108 DEFUN ("delete-directory-internal", Fdelete_directory_internal
,
2109 Sdelete_directory_internal
, 1, 1, 0,
2110 doc
: /* Delete the directory named DIRECTORY. Does not follow symlinks. */)
2111 (Lisp_Object directory
)
2113 const unsigned char *dir
;
2114 Lisp_Object handler
;
2115 Lisp_Object encoded_dir
;
2117 CHECK_STRING (directory
);
2118 directory
= Fdirectory_file_name (Fexpand_file_name (directory
, Qnil
));
2119 encoded_dir
= ENCODE_FILE (directory
);
2120 dir
= SDATA (encoded_dir
);
2122 if (rmdir (dir
) != 0)
2123 report_file_error ("Removing directory", list1 (directory
));
2128 DEFUN ("delete-file", Fdelete_file
, Sdelete_file
, 1, 2,
2129 "(list (read-file-name \
2130 (if (and delete-by-moving-to-trash (null current-prefix-arg)) \
2131 \"Move file to trash: \" \"Delete file: \") \
2132 nil default-directory (confirm-nonexistent-file-or-buffer)) \
2133 (null current-prefix-arg))",
2134 doc
: /* Delete file named FILENAME. If it is a symlink, remove the symlink.
2135 If file has multiple names, it continues to exist with the other names.
2136 TRASH non-nil means to trash the file instead of deleting, provided
2137 `delete-by-moving-to-trash' is non-nil.
2139 When called interactively, TRASH is t if no prefix argument is given.
2140 With a prefix argument, TRASH is nil. */)
2141 (Lisp_Object filename
, Lisp_Object trash
)
2143 Lisp_Object handler
;
2144 Lisp_Object encoded_file
;
2145 struct gcpro gcpro1
;
2148 if (!NILP (Ffile_directory_p (filename
))
2149 && NILP (Ffile_symlink_p (filename
)))
2150 xsignal2 (Qfile_error
,
2151 build_string ("Removing old name: is a directory"),
2154 filename
= Fexpand_file_name (filename
, Qnil
);
2156 handler
= Ffind_file_name_handler (filename
, Qdelete_file
);
2157 if (!NILP (handler
))
2158 return call3 (handler
, Qdelete_file
, filename
, trash
);
2160 if (delete_by_moving_to_trash
&& !NILP (trash
))
2161 return call1 (Qmove_file_to_trash
, filename
);
2163 encoded_file
= ENCODE_FILE (filename
);
2165 if (0 > unlink (SDATA (encoded_file
)))
2166 report_file_error ("Removing old name", list1 (filename
));
2171 internal_delete_file_1 (Lisp_Object ignore
)
2176 /* Delete file FILENAME, returning 1 if successful and 0 if failed.
2177 This ignores `delete-by-moving-to-trash'. */
2180 internal_delete_file (Lisp_Object filename
)
2184 tem
= internal_condition_case_2 (Fdelete_file
, filename
, Qnil
,
2185 Qt
, internal_delete_file_1
);
2189 DEFUN ("rename-file", Frename_file
, Srename_file
, 2, 3,
2190 "fRename file: \nGRename %s to file: \np",
2191 doc
: /* Rename FILE as NEWNAME. Both args must be strings.
2192 If file has names other than FILE, it continues to have those names.
2193 Signals a `file-already-exists' error if a file NEWNAME already exists
2194 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
2195 A number as third arg means request confirmation if NEWNAME already exists.
2196 This is what happens in interactive use with M-x. */)
2197 (Lisp_Object file
, Lisp_Object newname
, Lisp_Object ok_if_already_exists
)
2199 Lisp_Object handler
;
2200 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
2201 Lisp_Object encoded_file
, encoded_newname
, symlink_target
;
2203 symlink_target
= encoded_file
= encoded_newname
= Qnil
;
2204 GCPRO5 (file
, newname
, encoded_file
, encoded_newname
, symlink_target
);
2205 CHECK_STRING (file
);
2206 CHECK_STRING (newname
);
2207 file
= Fexpand_file_name (file
, Qnil
);
2209 if ((!NILP (Ffile_directory_p (newname
)))
2211 /* If the file names are identical but for the case,
2212 don't attempt to move directory to itself. */
2213 && (NILP (Fstring_equal (Fdowncase (file
), Fdowncase (newname
))))
2217 Lisp_Object fname
= NILP (Ffile_directory_p (file
))
2218 ? file
: Fdirectory_file_name (file
);
2219 newname
= Fexpand_file_name (Ffile_name_nondirectory (fname
), newname
);
2222 newname
= Fexpand_file_name (newname
, Qnil
);
2224 /* If the file name has special constructs in it,
2225 call the corresponding file handler. */
2226 handler
= Ffind_file_name_handler (file
, Qrename_file
);
2228 handler
= Ffind_file_name_handler (newname
, Qrename_file
);
2229 if (!NILP (handler
))
2230 RETURN_UNGCPRO (call4 (handler
, Qrename_file
,
2231 file
, newname
, ok_if_already_exists
));
2233 encoded_file
= ENCODE_FILE (file
);
2234 encoded_newname
= ENCODE_FILE (newname
);
2237 /* If the file names are identical but for the case, don't ask for
2238 confirmation: they simply want to change the letter-case of the
2240 if (NILP (Fstring_equal (Fdowncase (file
), Fdowncase (newname
))))
2242 if (NILP (ok_if_already_exists
)
2243 || INTEGERP (ok_if_already_exists
))
2244 barf_or_query_if_file_exists (newname
, "rename to it",
2245 INTEGERP (ok_if_already_exists
), 0, 0);
2246 if (0 > rename (SDATA (encoded_file
), SDATA (encoded_newname
)))
2252 symlink_target
= Ffile_symlink_p (file
);
2253 if (! NILP (symlink_target
))
2254 Fmake_symbolic_link (symlink_target
, newname
,
2255 NILP (ok_if_already_exists
) ? Qnil
: Qt
);
2258 if (!NILP (Ffile_directory_p (file
)))
2259 call4 (Qcopy_directory
, file
, newname
, Qt
, Qnil
);
2261 /* We have already prompted if it was an integer, so don't
2262 have copy-file prompt again. */
2263 Fcopy_file (file
, newname
,
2264 NILP (ok_if_already_exists
) ? Qnil
: Qt
,
2267 count
= SPECPDL_INDEX ();
2268 specbind (Qdelete_by_moving_to_trash
, Qnil
);
2270 if (!NILP (Ffile_directory_p (file
))
2272 && NILP (symlink_target
)
2275 call2 (Qdelete_directory
, file
, Qt
);
2277 Fdelete_file (file
, Qnil
);
2278 unbind_to (count
, Qnil
);
2281 report_file_error ("Renaming", list2 (file
, newname
));
2287 DEFUN ("add-name-to-file", Fadd_name_to_file
, Sadd_name_to_file
, 2, 3,
2288 "fAdd name to file: \nGName to add to %s: \np",
2289 doc
: /* Give FILE additional name NEWNAME. Both args must be strings.
2290 Signals a `file-already-exists' error if a file NEWNAME already exists
2291 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
2292 A number as third arg means request confirmation if NEWNAME already exists.
2293 This is what happens in interactive use with M-x. */)
2294 (Lisp_Object file
, Lisp_Object newname
, Lisp_Object ok_if_already_exists
)
2296 Lisp_Object handler
;
2297 Lisp_Object encoded_file
, encoded_newname
;
2298 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2300 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2301 encoded_file
= encoded_newname
= Qnil
;
2302 CHECK_STRING (file
);
2303 CHECK_STRING (newname
);
2304 file
= Fexpand_file_name (file
, Qnil
);
2306 if (!NILP (Ffile_directory_p (newname
)))
2307 newname
= Fexpand_file_name (Ffile_name_nondirectory (file
), newname
);
2309 newname
= Fexpand_file_name (newname
, Qnil
);
2311 /* If the file name has special constructs in it,
2312 call the corresponding file handler. */
2313 handler
= Ffind_file_name_handler (file
, Qadd_name_to_file
);
2314 if (!NILP (handler
))
2315 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2316 newname
, ok_if_already_exists
));
2318 /* If the new name has special constructs in it,
2319 call the corresponding file handler. */
2320 handler
= Ffind_file_name_handler (newname
, Qadd_name_to_file
);
2321 if (!NILP (handler
))
2322 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2323 newname
, ok_if_already_exists
));
2325 encoded_file
= ENCODE_FILE (file
);
2326 encoded_newname
= ENCODE_FILE (newname
);
2328 if (NILP (ok_if_already_exists
)
2329 || INTEGERP (ok_if_already_exists
))
2330 barf_or_query_if_file_exists (newname
, "make it a new name",
2331 INTEGERP (ok_if_already_exists
), 0, 0);
2333 unlink (SDATA (newname
));
2334 if (0 > link (SDATA (encoded_file
), SDATA (encoded_newname
)))
2335 report_file_error ("Adding new name", list2 (file
, newname
));
2341 DEFUN ("make-symbolic-link", Fmake_symbolic_link
, Smake_symbolic_link
, 2, 3,
2342 "FMake symbolic link to file: \nGMake symbolic link to file %s: \np",
2343 doc
: /* Make a symbolic link to FILENAME, named LINKNAME.
2344 Both args must be strings.
2345 Signals a `file-already-exists' error if a file LINKNAME already exists
2346 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
2347 A number as third arg means request confirmation if LINKNAME already exists.
2348 This happens for interactive use with M-x. */)
2349 (Lisp_Object filename
, Lisp_Object linkname
, Lisp_Object ok_if_already_exists
)
2351 Lisp_Object handler
;
2352 Lisp_Object encoded_filename
, encoded_linkname
;
2353 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2355 GCPRO4 (filename
, linkname
, encoded_filename
, encoded_linkname
);
2356 encoded_filename
= encoded_linkname
= Qnil
;
2357 CHECK_STRING (filename
);
2358 CHECK_STRING (linkname
);
2359 /* If the link target has a ~, we must expand it to get
2360 a truly valid file name. Otherwise, do not expand;
2361 we want to permit links to relative file names. */
2362 if (SREF (filename
, 0) == '~')
2363 filename
= Fexpand_file_name (filename
, Qnil
);
2365 if (!NILP (Ffile_directory_p (linkname
)))
2366 linkname
= Fexpand_file_name (Ffile_name_nondirectory (filename
), linkname
);
2368 linkname
= Fexpand_file_name (linkname
, Qnil
);
2370 /* If the file name has special constructs in it,
2371 call the corresponding file handler. */
2372 handler
= Ffind_file_name_handler (filename
, Qmake_symbolic_link
);
2373 if (!NILP (handler
))
2374 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2375 linkname
, ok_if_already_exists
));
2377 /* If the new link name has special constructs in it,
2378 call the corresponding file handler. */
2379 handler
= Ffind_file_name_handler (linkname
, Qmake_symbolic_link
);
2380 if (!NILP (handler
))
2381 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2382 linkname
, ok_if_already_exists
));
2385 encoded_filename
= ENCODE_FILE (filename
);
2386 encoded_linkname
= ENCODE_FILE (linkname
);
2388 if (NILP (ok_if_already_exists
)
2389 || INTEGERP (ok_if_already_exists
))
2390 barf_or_query_if_file_exists (linkname
, "make it a link",
2391 INTEGERP (ok_if_already_exists
), 0, 0);
2392 if (0 > symlink (SDATA (encoded_filename
),
2393 SDATA (encoded_linkname
)))
2395 /* If we didn't complain already, silently delete existing file. */
2396 if (errno
== EEXIST
)
2398 unlink (SDATA (encoded_linkname
));
2399 if (0 <= symlink (SDATA (encoded_filename
),
2400 SDATA (encoded_linkname
)))
2407 report_file_error ("Making symbolic link", list2 (filename
, linkname
));
2414 xsignal1 (Qfile_error
, build_string ("Symbolic links are not supported"));
2416 #endif /* S_IFLNK */
2420 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p
, Sfile_name_absolute_p
,
2422 doc
: /* Return t if file FILENAME specifies an absolute file name.
2423 On Unix, this is a name starting with a `/' or a `~'. */)
2424 (Lisp_Object filename
)
2426 CHECK_STRING (filename
);
2427 return file_name_absolute_p (SDATA (filename
)) ? Qt
: Qnil
;
2430 /* Return nonzero if file FILENAME exists and can be executed. */
2433 check_executable (char *filename
)
2436 int len
= strlen (filename
);
2439 if (stat (filename
, &st
) < 0)
2441 return ((st
.st_mode
& S_IEXEC
) != 0);
2442 #else /* not DOS_NT */
2443 #ifdef HAVE_EUIDACCESS
2444 return (euidaccess (filename
, 1) >= 0);
2446 /* Access isn't quite right because it uses the real uid
2447 and we really want to test with the effective uid.
2448 But Unix doesn't give us a right way to do it. */
2449 return (access (filename
, 1) >= 0);
2451 #endif /* not DOS_NT */
2454 /* Return nonzero if file FILENAME exists and can be written. */
2457 check_writable (const char *filename
)
2461 if (stat (filename
, &st
) < 0)
2463 return (st
.st_mode
& S_IWRITE
|| (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2464 #else /* not MSDOS */
2465 #ifdef HAVE_EUIDACCESS
2466 return (euidaccess (filename
, 2) >= 0);
2468 /* Access isn't quite right because it uses the real uid
2469 and we really want to test with the effective uid.
2470 But Unix doesn't give us a right way to do it.
2471 Opening with O_WRONLY could work for an ordinary file,
2472 but would lose for directories. */
2473 return (access (filename
, 2) >= 0);
2475 #endif /* not MSDOS */
2478 DEFUN ("file-exists-p", Ffile_exists_p
, Sfile_exists_p
, 1, 1, 0,
2479 doc
: /* Return t if file FILENAME exists (whether or not you can read it.)
2480 See also `file-readable-p' and `file-attributes'.
2481 This returns nil for a symlink to a nonexistent file.
2482 Use `file-symlink-p' to test for such links. */)
2483 (Lisp_Object filename
)
2485 Lisp_Object absname
;
2486 Lisp_Object handler
;
2487 struct stat statbuf
;
2489 CHECK_STRING (filename
);
2490 absname
= Fexpand_file_name (filename
, Qnil
);
2492 /* If the file name has special constructs in it,
2493 call the corresponding file handler. */
2494 handler
= Ffind_file_name_handler (absname
, Qfile_exists_p
);
2495 if (!NILP (handler
))
2496 return call2 (handler
, Qfile_exists_p
, absname
);
2498 absname
= ENCODE_FILE (absname
);
2500 return (stat (SDATA (absname
), &statbuf
) >= 0) ? Qt
: Qnil
;
2503 DEFUN ("file-executable-p", Ffile_executable_p
, Sfile_executable_p
, 1, 1, 0,
2504 doc
: /* Return t if FILENAME can be executed by you.
2505 For a directory, this means you can access files in that directory. */)
2506 (Lisp_Object filename
)
2508 Lisp_Object absname
;
2509 Lisp_Object handler
;
2511 CHECK_STRING (filename
);
2512 absname
= Fexpand_file_name (filename
, Qnil
);
2514 /* If the file name has special constructs in it,
2515 call the corresponding file handler. */
2516 handler
= Ffind_file_name_handler (absname
, Qfile_executable_p
);
2517 if (!NILP (handler
))
2518 return call2 (handler
, Qfile_executable_p
, absname
);
2520 absname
= ENCODE_FILE (absname
);
2522 return (check_executable (SDATA (absname
)) ? Qt
: Qnil
);
2525 DEFUN ("file-readable-p", Ffile_readable_p
, Sfile_readable_p
, 1, 1, 0,
2526 doc
: /* Return t if file FILENAME exists and you can read it.
2527 See also `file-exists-p' and `file-attributes'. */)
2528 (Lisp_Object filename
)
2530 Lisp_Object absname
;
2531 Lisp_Object handler
;
2534 struct stat statbuf
;
2536 CHECK_STRING (filename
);
2537 absname
= Fexpand_file_name (filename
, Qnil
);
2539 /* If the file name has special constructs in it,
2540 call the corresponding file handler. */
2541 handler
= Ffind_file_name_handler (absname
, Qfile_readable_p
);
2542 if (!NILP (handler
))
2543 return call2 (handler
, Qfile_readable_p
, absname
);
2545 absname
= ENCODE_FILE (absname
);
2547 #if defined(DOS_NT) || defined(macintosh)
2548 /* Under MS-DOS, Windows, and Macintosh, open does not work for
2550 if (access (SDATA (absname
), 0) == 0)
2553 #else /* not DOS_NT and not macintosh */
2555 #if defined (S_ISFIFO) && defined (O_NONBLOCK)
2556 /* Opening a fifo without O_NONBLOCK can wait.
2557 We don't want to wait. But we don't want to mess wth O_NONBLOCK
2558 except in the case of a fifo, on a system which handles it. */
2559 desc
= stat (SDATA (absname
), &statbuf
);
2562 if (S_ISFIFO (statbuf
.st_mode
))
2563 flags
|= O_NONBLOCK
;
2565 desc
= emacs_open (SDATA (absname
), flags
, 0);
2570 #endif /* not DOS_NT and not macintosh */
2573 /* Having this before file-symlink-p mysteriously caused it to be forgotten
2575 DEFUN ("file-writable-p", Ffile_writable_p
, Sfile_writable_p
, 1, 1, 0,
2576 doc
: /* Return t if file FILENAME can be written or created by you. */)
2577 (Lisp_Object filename
)
2579 Lisp_Object absname
, dir
, encoded
;
2580 Lisp_Object handler
;
2581 struct stat statbuf
;
2583 CHECK_STRING (filename
);
2584 absname
= Fexpand_file_name (filename
, Qnil
);
2586 /* If the file name has special constructs in it,
2587 call the corresponding file handler. */
2588 handler
= Ffind_file_name_handler (absname
, Qfile_writable_p
);
2589 if (!NILP (handler
))
2590 return call2 (handler
, Qfile_writable_p
, absname
);
2592 encoded
= ENCODE_FILE (absname
);
2593 if (stat (SDATA (encoded
), &statbuf
) >= 0)
2594 return (check_writable (SDATA (encoded
))
2597 dir
= Ffile_name_directory (absname
);
2600 dir
= Fdirectory_file_name (dir
);
2603 dir
= ENCODE_FILE (dir
);
2605 /* The read-only attribute of the parent directory doesn't affect
2606 whether a file or directory can be created within it. Some day we
2607 should check ACLs though, which do affect this. */
2608 if (stat (SDATA (dir
), &statbuf
) < 0)
2610 return (statbuf
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
2612 return (check_writable (!NILP (dir
) ? (char *) SDATA (dir
) : "")
2617 DEFUN ("access-file", Faccess_file
, Saccess_file
, 2, 2, 0,
2618 doc
: /* Access file FILENAME, and get an error if that does not work.
2619 The second argument STRING is used in the error message.
2620 If there is no error, returns nil. */)
2621 (Lisp_Object filename
, Lisp_Object string
)
2623 Lisp_Object handler
, encoded_filename
, absname
;
2626 CHECK_STRING (filename
);
2627 absname
= Fexpand_file_name (filename
, Qnil
);
2629 CHECK_STRING (string
);
2631 /* If the file name has special constructs in it,
2632 call the corresponding file handler. */
2633 handler
= Ffind_file_name_handler (absname
, Qaccess_file
);
2634 if (!NILP (handler
))
2635 return call3 (handler
, Qaccess_file
, absname
, string
);
2637 encoded_filename
= ENCODE_FILE (absname
);
2639 fd
= emacs_open (SDATA (encoded_filename
), O_RDONLY
, 0);
2641 report_file_error (SDATA (string
), Fcons (filename
, Qnil
));
2647 DEFUN ("file-symlink-p", Ffile_symlink_p
, Sfile_symlink_p
, 1, 1, 0,
2648 doc
: /* Return non-nil if file FILENAME is the name of a symbolic link.
2649 The value is the link target, as a string.
2650 Otherwise it returns nil.
2652 This function returns t when given the name of a symlink that
2653 points to a nonexistent file. */)
2654 (Lisp_Object filename
)
2656 Lisp_Object handler
;
2658 CHECK_STRING (filename
);
2659 filename
= Fexpand_file_name (filename
, Qnil
);
2661 /* If the file name has special constructs in it,
2662 call the corresponding file handler. */
2663 handler
= Ffind_file_name_handler (filename
, Qfile_symlink_p
);
2664 if (!NILP (handler
))
2665 return call2 (handler
, Qfile_symlink_p
, filename
);
2674 filename
= ENCODE_FILE (filename
);
2681 buf
= (char *) xrealloc (buf
, bufsize
);
2682 memset (buf
, 0, bufsize
);
2685 valsize
= readlink (SDATA (filename
), buf
, bufsize
);
2689 /* HP-UX reports ERANGE if buffer is too small. */
2690 if (errno
== ERANGE
)
2700 while (valsize
>= bufsize
);
2702 val
= make_string (buf
, valsize
);
2703 if (buf
[0] == '/' && strchr (buf
, ':'))
2704 val
= concat2 (build_string ("/:"), val
);
2706 val
= DECODE_FILE (val
);
2709 #else /* not S_IFLNK */
2711 #endif /* not S_IFLNK */
2714 DEFUN ("file-directory-p", Ffile_directory_p
, Sfile_directory_p
, 1, 1, 0,
2715 doc
: /* Return t if FILENAME names an existing directory.
2716 Symbolic links to directories count as directories.
2717 See `file-symlink-p' to distinguish symlinks. */)
2718 (Lisp_Object filename
)
2720 register Lisp_Object absname
;
2722 Lisp_Object handler
;
2724 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2726 /* If the file name has special constructs in it,
2727 call the corresponding file handler. */
2728 handler
= Ffind_file_name_handler (absname
, Qfile_directory_p
);
2729 if (!NILP (handler
))
2730 return call2 (handler
, Qfile_directory_p
, absname
);
2732 absname
= ENCODE_FILE (absname
);
2734 if (stat (SDATA (absname
), &st
) < 0)
2736 return (st
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
2739 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p
, Sfile_accessible_directory_p
, 1, 1, 0,
2740 doc
: /* Return t if file FILENAME names a directory you can open.
2741 For the value to be t, FILENAME must specify the name of a directory as a file,
2742 and the directory must allow you to open files in it. In order to use a
2743 directory as a buffer's current directory, this predicate must return true.
2744 A directory name spec may be given instead; then the value is t
2745 if the directory so specified exists and really is a readable and
2746 searchable directory. */)
2747 (Lisp_Object filename
)
2749 Lisp_Object handler
;
2751 struct gcpro gcpro1
;
2753 /* If the file name has special constructs in it,
2754 call the corresponding file handler. */
2755 handler
= Ffind_file_name_handler (filename
, Qfile_accessible_directory_p
);
2756 if (!NILP (handler
))
2757 return call2 (handler
, Qfile_accessible_directory_p
, filename
);
2760 tem
= (NILP (Ffile_directory_p (filename
))
2761 || NILP (Ffile_executable_p (filename
)));
2763 return tem
? Qnil
: Qt
;
2766 DEFUN ("file-regular-p", Ffile_regular_p
, Sfile_regular_p
, 1, 1, 0,
2767 doc
: /* Return t if FILENAME names a regular file.
2768 This is the sort of file that holds an ordinary stream of data bytes.
2769 Symbolic links to regular files count as regular files.
2770 See `file-symlink-p' to distinguish symlinks. */)
2771 (Lisp_Object filename
)
2773 register Lisp_Object absname
;
2775 Lisp_Object handler
;
2777 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2779 /* If the file name has special constructs in it,
2780 call the corresponding file handler. */
2781 handler
= Ffind_file_name_handler (absname
, Qfile_regular_p
);
2782 if (!NILP (handler
))
2783 return call2 (handler
, Qfile_regular_p
, absname
);
2785 absname
= ENCODE_FILE (absname
);
2790 Lisp_Object tem
= Vw32_get_true_file_attributes
;
2792 /* Tell stat to use expensive method to get accurate info. */
2793 Vw32_get_true_file_attributes
= Qt
;
2794 result
= stat (SDATA (absname
), &st
);
2795 Vw32_get_true_file_attributes
= tem
;
2799 return (st
.st_mode
& S_IFMT
) == S_IFREG
? Qt
: Qnil
;
2802 if (stat (SDATA (absname
), &st
) < 0)
2804 return (st
.st_mode
& S_IFMT
) == S_IFREG
? Qt
: Qnil
;
2808 DEFUN ("file-selinux-context", Ffile_selinux_context
,
2809 Sfile_selinux_context
, 1, 1, 0,
2810 doc
: /* Return SELinux context of file named FILENAME,
2811 as a list ("user", "role", "type", "range"). Return (nil, nil, nil, nil)
2812 if file does not exist, is not accessible, or SELinux is disabled */)
2813 (Lisp_Object filename
)
2815 Lisp_Object absname
;
2816 Lisp_Object values
[4];
2817 Lisp_Object handler
;
2819 security_context_t con
;
2824 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2826 /* If the file name has special constructs in it,
2827 call the corresponding file handler. */
2828 handler
= Ffind_file_name_handler (absname
, Qfile_selinux_context
);
2829 if (!NILP (handler
))
2830 return call2 (handler
, Qfile_selinux_context
, absname
);
2832 absname
= ENCODE_FILE (absname
);
2839 if (is_selinux_enabled ())
2841 conlength
= lgetfilecon (SDATA (absname
), &con
);
2844 context
= context_new (con
);
2845 if (context_user_get (context
))
2846 values
[0] = build_string (context_user_get (context
));
2847 if (context_role_get (context
))
2848 values
[1] = build_string (context_role_get (context
));
2849 if (context_type_get (context
))
2850 values
[2] = build_string (context_type_get (context
));
2851 if (context_range_get (context
))
2852 values
[3] = build_string (context_range_get (context
));
2853 context_free (context
);
2860 return Flist (sizeof(values
) / sizeof(values
[0]), values
);
2863 DEFUN ("set-file-selinux-context", Fset_file_selinux_context
,
2864 Sset_file_selinux_context
, 2, 2, 0,
2865 doc
: /* Set SELinux context of file named FILENAME to CONTEXT
2866 as a list ("user", "role", "type", "range"). Has no effect if SELinux
2868 (Lisp_Object filename
, Lisp_Object context
)
2870 Lisp_Object absname
, encoded_absname
;
2871 Lisp_Object handler
;
2872 Lisp_Object user
= CAR_SAFE (context
);
2873 Lisp_Object role
= CAR_SAFE (CDR_SAFE (context
));
2874 Lisp_Object type
= CAR_SAFE (CDR_SAFE (CDR_SAFE (context
)));
2875 Lisp_Object range
= CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (context
))));
2877 security_context_t con
;
2878 int fail
, conlength
;
2879 context_t parsed_con
;
2882 absname
= Fexpand_file_name (filename
, current_buffer
->directory
);
2884 /* If the file name has special constructs in it,
2885 call the corresponding file handler. */
2886 handler
= Ffind_file_name_handler (absname
, Qset_file_selinux_context
);
2887 if (!NILP (handler
))
2888 return call3 (handler
, Qset_file_selinux_context
, absname
, context
);
2890 encoded_absname
= ENCODE_FILE (absname
);
2893 if (is_selinux_enabled ())
2895 /* Get current file context. */
2896 conlength
= lgetfilecon (SDATA (encoded_absname
), &con
);
2899 parsed_con
= context_new (con
);
2900 /* Change the parts defined in the parameter.*/
2903 if (context_user_set (parsed_con
, SDATA (user
)))
2904 error ("Doing context_user_set");
2908 if (context_role_set (parsed_con
, SDATA (role
)))
2909 error ("Doing context_role_set");
2913 if (context_type_set (parsed_con
, SDATA (type
)))
2914 error ("Doing context_type_set");
2916 if (STRINGP (range
))
2918 if (context_range_set (parsed_con
, SDATA (range
)))
2919 error ("Doing context_range_set");
2922 /* Set the modified context back to the file. */
2923 fail
= lsetfilecon (SDATA (encoded_absname
), context_str (parsed_con
));
2925 report_file_error ("Doing lsetfilecon", Fcons (absname
, Qnil
));
2927 context_free (parsed_con
);
2930 report_file_error("Doing lgetfilecon", Fcons (absname
, Qnil
));
2940 DEFUN ("file-modes", Ffile_modes
, Sfile_modes
, 1, 1, 0,
2941 doc
: /* Return mode bits of file named FILENAME, as an integer.
2942 Return nil, if file does not exist or is not accessible. */)
2943 (Lisp_Object filename
)
2945 Lisp_Object absname
;
2947 Lisp_Object handler
;
2949 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2951 /* If the file name has special constructs in it,
2952 call the corresponding file handler. */
2953 handler
= Ffind_file_name_handler (absname
, Qfile_modes
);
2954 if (!NILP (handler
))
2955 return call2 (handler
, Qfile_modes
, absname
);
2957 absname
= ENCODE_FILE (absname
);
2959 if (stat (SDATA (absname
), &st
) < 0)
2962 return make_number (st
.st_mode
& 07777);
2965 DEFUN ("set-file-modes", Fset_file_modes
, Sset_file_modes
, 2, 2,
2966 "(let ((file (read-file-name \"File: \"))) \
2967 (list file (read-file-modes nil file)))",
2968 doc
: /* Set mode bits of file named FILENAME to MODE (an integer).
2969 Only the 12 low bits of MODE are used.
2971 Interactively, mode bits are read by `read-file-modes', which accepts
2972 symbolic notation, like the `chmod' command from GNU Coreutils. */)
2973 (Lisp_Object filename
, Lisp_Object mode
)
2975 Lisp_Object absname
, encoded_absname
;
2976 Lisp_Object handler
;
2978 absname
= Fexpand_file_name (filename
, current_buffer
->directory
);
2979 CHECK_NUMBER (mode
);
2981 /* If the file name has special constructs in it,
2982 call the corresponding file handler. */
2983 handler
= Ffind_file_name_handler (absname
, Qset_file_modes
);
2984 if (!NILP (handler
))
2985 return call3 (handler
, Qset_file_modes
, absname
, mode
);
2987 encoded_absname
= ENCODE_FILE (absname
);
2989 if (chmod (SDATA (encoded_absname
), XINT (mode
)) < 0)
2990 report_file_error ("Doing chmod", Fcons (absname
, Qnil
));
2995 DEFUN ("set-default-file-modes", Fset_default_file_modes
, Sset_default_file_modes
, 1, 1, 0,
2996 doc
: /* Set the file permission bits for newly created files.
2997 The argument MODE should be an integer; only the low 9 bits are used.
2998 This setting is inherited by subprocesses. */)
3001 CHECK_NUMBER (mode
);
3003 umask ((~ XINT (mode
)) & 0777);
3008 DEFUN ("default-file-modes", Fdefault_file_modes
, Sdefault_file_modes
, 0, 0, 0,
3009 doc
: /* Return the default file protection for created files.
3010 The value is an integer. */)
3016 realmask
= umask (0);
3019 XSETINT (value
, (~ realmask
) & 0777);
3024 DEFUN ("set-file-times", Fset_file_times
, Sset_file_times
, 1, 2, 0,
3025 doc
: /* Set times of file FILENAME to TIME.
3026 Set both access and modification times.
3027 Return t on success, else nil.
3028 Use the current time if TIME is nil. TIME is in the format of
3030 (Lisp_Object filename
, Lisp_Object time
)
3032 Lisp_Object absname
, encoded_absname
;
3033 Lisp_Object handler
;
3037 if (! lisp_time_argument (time
, &sec
, &usec
))
3038 error ("Invalid time specification");
3040 absname
= Fexpand_file_name (filename
, current_buffer
->directory
);
3042 /* If the file name has special constructs in it,
3043 call the corresponding file handler. */
3044 handler
= Ffind_file_name_handler (absname
, Qset_file_times
);
3045 if (!NILP (handler
))
3046 return call3 (handler
, Qset_file_times
, absname
, time
);
3048 encoded_absname
= ENCODE_FILE (absname
);
3053 EMACS_SET_SECS (t
, sec
);
3054 EMACS_SET_USECS (t
, usec
);
3056 if (set_file_times (SDATA (encoded_absname
), t
, t
))
3061 /* Setting times on a directory always fails. */
3062 if (stat (SDATA (encoded_absname
), &st
) == 0
3063 && (st
.st_mode
& S_IFMT
) == S_IFDIR
)
3066 report_file_error ("Setting file times", Fcons (absname
, Qnil
));
3075 DEFUN ("unix-sync", Funix_sync
, Sunix_sync
, 0, 0, "",
3076 doc
: /* Tell Unix to finish all pending disk updates. */)
3083 #endif /* HAVE_SYNC */
3085 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p
, Sfile_newer_than_file_p
, 2, 2, 0,
3086 doc
: /* Return t if file FILE1 is newer than file FILE2.
3087 If FILE1 does not exist, the answer is nil;
3088 otherwise, if FILE2 does not exist, the answer is t. */)
3089 (Lisp_Object file1
, Lisp_Object file2
)
3091 Lisp_Object absname1
, absname2
;
3094 Lisp_Object handler
;
3095 struct gcpro gcpro1
, gcpro2
;
3097 CHECK_STRING (file1
);
3098 CHECK_STRING (file2
);
3101 GCPRO2 (absname1
, file2
);
3102 absname1
= expand_and_dir_to_file (file1
, current_buffer
->directory
);
3103 absname2
= expand_and_dir_to_file (file2
, current_buffer
->directory
);
3106 /* If the file name has special constructs in it,
3107 call the corresponding file handler. */
3108 handler
= Ffind_file_name_handler (absname1
, Qfile_newer_than_file_p
);
3110 handler
= Ffind_file_name_handler (absname2
, Qfile_newer_than_file_p
);
3111 if (!NILP (handler
))
3112 return call3 (handler
, Qfile_newer_than_file_p
, absname1
, absname2
);
3114 GCPRO2 (absname1
, absname2
);
3115 absname1
= ENCODE_FILE (absname1
);
3116 absname2
= ENCODE_FILE (absname2
);
3119 if (stat (SDATA (absname1
), &st
) < 0)
3122 mtime1
= st
.st_mtime
;
3124 if (stat (SDATA (absname2
), &st
) < 0)
3127 return (mtime1
> st
.st_mtime
) ? Qt
: Qnil
;
3131 Lisp_Object Qfind_buffer_file_type
;
3134 #ifndef READ_BUF_SIZE
3135 #define READ_BUF_SIZE (64 << 10)
3138 /* This function is called after Lisp functions to decide a coding
3139 system are called, or when they cause an error. Before they are
3140 called, the current buffer is set unibyte and it contains only a
3141 newly inserted text (thus the buffer was empty before the
3144 The functions may set markers, overlays, text properties, or even
3145 alter the buffer contents, change the current buffer.
3147 Here, we reset all those changes by:
3148 o set back the current buffer.
3149 o move all markers and overlays to BEG.
3150 o remove all text properties.
3151 o set back the buffer multibyteness. */
3154 decide_coding_unwind (Lisp_Object unwind_data
)
3156 Lisp_Object multibyte
, undo_list
, buffer
;
3158 multibyte
= XCAR (unwind_data
);
3159 unwind_data
= XCDR (unwind_data
);
3160 undo_list
= XCAR (unwind_data
);
3161 buffer
= XCDR (unwind_data
);
3163 if (current_buffer
!= XBUFFER (buffer
))
3164 set_buffer_internal (XBUFFER (buffer
));
3165 adjust_markers_for_delete (BEG
, BEG_BYTE
, Z
, Z_BYTE
);
3166 adjust_overlays_for_delete (BEG
, Z
- BEG
);
3167 BUF_INTERVALS (current_buffer
) = 0;
3168 TEMP_SET_PT_BOTH (BEG
, BEG_BYTE
);
3170 /* Now we are safe to change the buffer's multibyteness directly. */
3171 current_buffer
->enable_multibyte_characters
= multibyte
;
3172 current_buffer
->undo_list
= undo_list
;
3178 /* Used to pass values from insert-file-contents to read_non_regular. */
3180 static int non_regular_fd
;
3181 static EMACS_INT non_regular_inserted
;
3182 static EMACS_INT non_regular_nbytes
;
3185 /* Read from a non-regular file.
3186 Read non_regular_nbytes bytes max from non_regular_fd.
3187 Non_regular_inserted specifies where to put the read bytes.
3188 Value is the number of bytes read. */
3191 read_non_regular (Lisp_Object ignore
)
3197 nbytes
= emacs_read (non_regular_fd
,
3198 BEG_ADDR
+ PT_BYTE
- BEG_BYTE
+ non_regular_inserted
,
3199 non_regular_nbytes
);
3201 return make_number (nbytes
);
3205 /* Condition-case handler used when reading from non-regular files
3206 in insert-file-contents. */
3209 read_non_regular_quit (Lisp_Object ignore
)
3215 DEFUN ("insert-file-contents", Finsert_file_contents
, Sinsert_file_contents
,
3217 doc
: /* Insert contents of file FILENAME after point.
3218 Returns list of absolute file name and number of characters inserted.
3219 If second argument VISIT is non-nil, the buffer's visited filename and
3220 last save file modtime are set, and it is marked unmodified. If
3221 visiting and the file does not exist, visiting is completed before the
3224 The optional third and fourth arguments BEG and END specify what portion
3225 of the file to insert. These arguments count bytes in the file, not
3226 characters in the buffer. If VISIT is non-nil, BEG and END must be nil.
3228 If optional fifth argument REPLACE is non-nil, replace the current
3229 buffer contents (in the accessible portion) with the file contents.
3230 This is better than simply deleting and inserting the whole thing
3231 because (1) it preserves some marker positions and (2) it puts less data
3232 in the undo list. When REPLACE is non-nil, the second return value is
3233 the number of characters that replace previous buffer contents.
3235 This function does code conversion according to the value of
3236 `coding-system-for-read' or `file-coding-system-alist', and sets the
3237 variable `last-coding-system-used' to the coding system actually used. */)
3238 (Lisp_Object filename
, Lisp_Object visit
, Lisp_Object beg
, Lisp_Object end
, Lisp_Object replace
)
3242 EMACS_INT inserted
= 0;
3244 register EMACS_INT how_much
;
3245 register EMACS_INT unprocessed
;
3246 int count
= SPECPDL_INDEX ();
3247 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
3248 Lisp_Object handler
, val
, insval
, orig_filename
, old_undo
;
3250 EMACS_INT total
= 0;
3251 int not_regular
= 0;
3252 unsigned char read_buf
[READ_BUF_SIZE
];
3253 struct coding_system coding
;
3254 unsigned char buffer
[1 << 14];
3255 int replace_handled
= 0;
3256 int set_coding_system
= 0;
3257 Lisp_Object coding_system
;
3259 Lisp_Object old_Vdeactivate_mark
= Vdeactivate_mark
;
3260 int we_locked_file
= 0;
3261 int deferred_remove_unwind_protect
= 0;
3263 if (current_buffer
->base_buffer
&& ! NILP (visit
))
3264 error ("Cannot do file visiting in an indirect buffer");
3266 if (!NILP (current_buffer
->read_only
))
3267 Fbarf_if_buffer_read_only ();
3271 orig_filename
= Qnil
;
3274 GCPRO5 (filename
, val
, p
, orig_filename
, old_undo
);
3276 CHECK_STRING (filename
);
3277 filename
= Fexpand_file_name (filename
, Qnil
);
3279 /* The value Qnil means that the coding system is not yet
3281 coding_system
= Qnil
;
3283 /* If the file name has special constructs in it,
3284 call the corresponding file handler. */
3285 handler
= Ffind_file_name_handler (filename
, Qinsert_file_contents
);
3286 if (!NILP (handler
))
3288 val
= call6 (handler
, Qinsert_file_contents
, filename
,
3289 visit
, beg
, end
, replace
);
3290 if (CONSP (val
) && CONSP (XCDR (val
)))
3291 inserted
= XINT (XCAR (XCDR (val
)));
3295 orig_filename
= filename
;
3296 filename
= ENCODE_FILE (filename
);
3302 Lisp_Object tem
= Vw32_get_true_file_attributes
;
3304 /* Tell stat to use expensive method to get accurate info. */
3305 Vw32_get_true_file_attributes
= Qt
;
3306 total
= stat (SDATA (filename
), &st
);
3307 Vw32_get_true_file_attributes
= tem
;
3311 if (stat (SDATA (filename
), &st
) < 0)
3312 #endif /* WINDOWSNT */
3314 if (fd
>= 0) emacs_close (fd
);
3317 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
3320 if (!NILP (Vcoding_system_for_read
))
3321 Fset (Qbuffer_file_coding_system
, Vcoding_system_for_read
);
3326 /* This code will need to be changed in order to work on named
3327 pipes, and it's probably just not worth it. So we should at
3328 least signal an error. */
3329 if (!S_ISREG (st
.st_mode
))
3336 if (! NILP (replace
) || ! NILP (beg
) || ! NILP (end
))
3337 xsignal2 (Qfile_error
,
3338 build_string ("not a regular file"), orig_filename
);
3343 if ((fd
= emacs_open (SDATA (filename
), O_RDONLY
, 0)) < 0)
3346 /* Replacement should preserve point as it preserves markers. */
3347 if (!NILP (replace
))
3348 record_unwind_protect (restore_point_unwind
, Fpoint_marker ());
3350 record_unwind_protect (close_file_unwind
, make_number (fd
));
3352 /* Can happen on any platform that uses long as type of off_t, but allows
3353 file sizes to exceed 2Gb, so give a suitable message. */
3354 if (! not_regular
&& st
.st_size
< 0)
3355 error ("Maximum buffer size exceeded");
3357 /* Prevent redisplay optimizations. */
3358 current_buffer
->clip_changed
= 1;
3362 if (!NILP (beg
) || !NILP (end
))
3363 error ("Attempt to visit less than an entire file");
3364 if (BEG
< Z
&& NILP (replace
))
3365 error ("Cannot do file visiting in a non-empty buffer");
3371 XSETFASTINT (beg
, 0);
3379 XSETINT (end
, st
.st_size
);
3381 /* Arithmetic overflow can occur if an Emacs integer cannot
3382 represent the file size, or if the calculations below
3383 overflow. The calculations below double the file size
3384 twice, so check that it can be multiplied by 4 safely. */
3385 if (XINT (end
) != st
.st_size
3386 /* Actually, it should test either INT_MAX or LONG_MAX
3387 depending on which one is used for EMACS_INT. But in
3388 any case, in practice, this test is redundant with the
3390 || st.st_size > INT_MAX / 4 */)
3391 error ("Maximum buffer size exceeded");
3393 /* The file size returned from stat may be zero, but data
3394 may be readable nonetheless, for example when this is a
3395 file in the /proc filesystem. */
3396 if (st
.st_size
== 0)
3397 XSETINT (end
, READ_BUF_SIZE
);
3401 if (EQ (Vcoding_system_for_read
, Qauto_save_coding
))
3403 coding_system
= coding_inherit_eol_type (Qutf_8_emacs
, Qunix
);
3404 setup_coding_system (coding_system
, &coding
);
3405 /* Ensure we set Vlast_coding_system_used. */
3406 set_coding_system
= 1;
3410 /* Decide the coding system to use for reading the file now
3411 because we can't use an optimized method for handling
3412 `coding:' tag if the current buffer is not empty. */
3413 if (!NILP (Vcoding_system_for_read
))
3414 coding_system
= Vcoding_system_for_read
;
3417 /* Don't try looking inside a file for a coding system
3418 specification if it is not seekable. */
3419 if (! not_regular
&& ! NILP (Vset_auto_coding_function
))
3421 /* Find a coding system specified in the heading two
3422 lines or in the tailing several lines of the file.
3423 We assume that the 1K-byte and 3K-byte for heading
3424 and tailing respectively are sufficient for this
3428 if (st
.st_size
<= (1024 * 4))
3429 nread
= emacs_read (fd
, read_buf
, 1024 * 4);
3432 nread
= emacs_read (fd
, read_buf
, 1024);
3435 if (lseek (fd
, st
.st_size
- (1024 * 3), 0) < 0)
3436 report_file_error ("Setting file position",
3437 Fcons (orig_filename
, Qnil
));
3438 nread
+= emacs_read (fd
, read_buf
+ nread
, 1024 * 3);
3443 error ("IO error reading %s: %s",
3444 SDATA (orig_filename
), emacs_strerror (errno
));
3447 struct buffer
*prev
= current_buffer
;
3451 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
3453 buffer
= Fget_buffer_create (build_string (" *code-converting-work*"));
3454 buf
= XBUFFER (buffer
);
3456 delete_all_overlays (buf
);
3457 buf
->directory
= current_buffer
->directory
;
3458 buf
->read_only
= Qnil
;
3459 buf
->filename
= Qnil
;
3460 buf
->undo_list
= Qt
;
3461 eassert (buf
->overlays_before
== NULL
);
3462 eassert (buf
->overlays_after
== NULL
);
3464 set_buffer_internal (buf
);
3466 buf
->enable_multibyte_characters
= Qnil
;
3468 insert_1_both (read_buf
, nread
, nread
, 0, 0, 0);
3469 TEMP_SET_PT_BOTH (BEG
, BEG_BYTE
);
3470 coding_system
= call2 (Vset_auto_coding_function
,
3471 filename
, make_number (nread
));
3472 set_buffer_internal (prev
);
3474 /* Discard the unwind protect for recovering the
3478 /* Rewind the file for the actual read done later. */
3479 if (lseek (fd
, 0, 0) < 0)
3480 report_file_error ("Setting file position",
3481 Fcons (orig_filename
, Qnil
));
3485 if (NILP (coding_system
))
3487 /* If we have not yet decided a coding system, check
3488 file-coding-system-alist. */
3489 Lisp_Object args
[6];
3491 args
[0] = Qinsert_file_contents
, args
[1] = orig_filename
;
3492 args
[2] = visit
, args
[3] = beg
, args
[4] = end
, args
[5] = replace
;
3493 coding_system
= Ffind_operation_coding_system (6, args
);
3494 if (CONSP (coding_system
))
3495 coding_system
= XCAR (coding_system
);
3499 if (NILP (coding_system
))
3500 coding_system
= Qundecided
;
3502 CHECK_CODING_SYSTEM (coding_system
);
3504 if (NILP (current_buffer
->enable_multibyte_characters
))
3505 /* We must suppress all character code conversion except for
3506 end-of-line conversion. */
3507 coding_system
= raw_text_coding_system (coding_system
);
3509 setup_coding_system (coding_system
, &coding
);
3510 /* Ensure we set Vlast_coding_system_used. */
3511 set_coding_system
= 1;
3514 /* If requested, replace the accessible part of the buffer
3515 with the file contents. Avoid replacing text at the
3516 beginning or end of the buffer that matches the file contents;
3517 that preserves markers pointing to the unchanged parts.
3519 Here we implement this feature in an optimized way
3520 for the case where code conversion is NOT needed.
3521 The following if-statement handles the case of conversion
3522 in a less optimal way.
3524 If the code conversion is "automatic" then we try using this
3525 method and hope for the best.
3526 But if we discover the need for conversion, we give up on this method
3527 and let the following if-statement handle the replace job. */
3530 && (NILP (coding_system
)
3531 || ! CODING_REQUIRE_DECODING (&coding
)))
3533 /* same_at_start and same_at_end count bytes,
3534 because file access counts bytes
3535 and BEG and END count bytes. */
3536 EMACS_INT same_at_start
= BEGV_BYTE
;
3537 EMACS_INT same_at_end
= ZV_BYTE
;
3539 /* There is still a possibility we will find the need to do code
3540 conversion. If that happens, we set this variable to 1 to
3541 give up on handling REPLACE in the optimized way. */
3542 int giveup_match_end
= 0;
3544 if (XINT (beg
) != 0)
3546 if (lseek (fd
, XINT (beg
), 0) < 0)
3547 report_file_error ("Setting file position",
3548 Fcons (orig_filename
, Qnil
));
3553 /* Count how many chars at the start of the file
3554 match the text at the beginning of the buffer. */
3557 EMACS_INT nread
, bufpos
;
3559 nread
= emacs_read (fd
, buffer
, sizeof buffer
);
3561 error ("IO error reading %s: %s",
3562 SDATA (orig_filename
), emacs_strerror (errno
));
3563 else if (nread
== 0)
3566 if (CODING_REQUIRE_DETECTION (&coding
))
3568 coding_system
= detect_coding_system (buffer
, nread
, nread
, 1, 0,
3570 setup_coding_system (coding_system
, &coding
);
3573 if (CODING_REQUIRE_DECODING (&coding
))
3574 /* We found that the file should be decoded somehow.
3575 Let's give up here. */
3577 giveup_match_end
= 1;
3582 while (bufpos
< nread
&& same_at_start
< ZV_BYTE
3583 && FETCH_BYTE (same_at_start
) == buffer
[bufpos
])
3584 same_at_start
++, bufpos
++;
3585 /* If we found a discrepancy, stop the scan.
3586 Otherwise loop around and scan the next bufferful. */
3587 if (bufpos
!= nread
)
3591 /* If the file matches the buffer completely,
3592 there's no need to replace anything. */
3593 if (same_at_start
- BEGV_BYTE
== XINT (end
))
3597 /* Truncate the buffer to the size of the file. */
3598 del_range_1 (same_at_start
, same_at_end
, 0, 0);
3603 /* Count how many chars at the end of the file
3604 match the text at the end of the buffer. But, if we have
3605 already found that decoding is necessary, don't waste time. */
3606 while (!giveup_match_end
)
3608 EMACS_INT total_read
, nread
, bufpos
, curpos
, trial
;
3610 /* At what file position are we now scanning? */
3611 curpos
= XINT (end
) - (ZV_BYTE
- same_at_end
);
3612 /* If the entire file matches the buffer tail, stop the scan. */
3615 /* How much can we scan in the next step? */
3616 trial
= min (curpos
, sizeof buffer
);
3617 if (lseek (fd
, curpos
- trial
, 0) < 0)
3618 report_file_error ("Setting file position",
3619 Fcons (orig_filename
, Qnil
));
3621 total_read
= nread
= 0;
3622 while (total_read
< trial
)
3624 nread
= emacs_read (fd
, buffer
+ total_read
, trial
- total_read
);
3626 error ("IO error reading %s: %s",
3627 SDATA (orig_filename
), emacs_strerror (errno
));
3628 else if (nread
== 0)
3630 total_read
+= nread
;
3633 /* Scan this bufferful from the end, comparing with
3634 the Emacs buffer. */
3635 bufpos
= total_read
;
3637 /* Compare with same_at_start to avoid counting some buffer text
3638 as matching both at the file's beginning and at the end. */
3639 while (bufpos
> 0 && same_at_end
> same_at_start
3640 && FETCH_BYTE (same_at_end
- 1) == buffer
[bufpos
- 1])
3641 same_at_end
--, bufpos
--;
3643 /* If we found a discrepancy, stop the scan.
3644 Otherwise loop around and scan the preceding bufferful. */
3647 /* If this discrepancy is because of code conversion,
3648 we cannot use this method; giveup and try the other. */
3649 if (same_at_end
> same_at_start
3650 && FETCH_BYTE (same_at_end
- 1) >= 0200
3651 && ! NILP (current_buffer
->enable_multibyte_characters
)
3652 && (CODING_MAY_REQUIRE_DECODING (&coding
)))
3653 giveup_match_end
= 1;
3662 if (! giveup_match_end
)
3666 /* We win! We can handle REPLACE the optimized way. */
3668 /* Extend the start of non-matching text area to multibyte
3669 character boundary. */
3670 if (! NILP (current_buffer
->enable_multibyte_characters
))
3671 while (same_at_start
> BEGV_BYTE
3672 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_start
)))
3675 /* Extend the end of non-matching text area to multibyte
3676 character boundary. */
3677 if (! NILP (current_buffer
->enable_multibyte_characters
))
3678 while (same_at_end
< ZV_BYTE
3679 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_end
)))
3682 /* Don't try to reuse the same piece of text twice. */
3683 overlap
= (same_at_start
- BEGV_BYTE
3684 - (same_at_end
+ st
.st_size
- ZV
));
3686 same_at_end
+= overlap
;
3688 /* Arrange to read only the nonmatching middle part of the file. */
3689 XSETFASTINT (beg
, XINT (beg
) + (same_at_start
- BEGV_BYTE
));
3690 XSETFASTINT (end
, XINT (end
) - (ZV_BYTE
- same_at_end
));
3692 del_range_byte (same_at_start
, same_at_end
, 0);
3693 /* Insert from the file at the proper position. */
3694 temp
= BYTE_TO_CHAR (same_at_start
);
3695 SET_PT_BOTH (temp
, same_at_start
);
3697 /* If display currently starts at beginning of line,
3698 keep it that way. */
3699 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3700 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3702 replace_handled
= 1;
3706 /* If requested, replace the accessible part of the buffer
3707 with the file contents. Avoid replacing text at the
3708 beginning or end of the buffer that matches the file contents;
3709 that preserves markers pointing to the unchanged parts.
3711 Here we implement this feature for the case where code conversion
3712 is needed, in a simple way that needs a lot of memory.
3713 The preceding if-statement handles the case of no conversion
3714 in a more optimized way. */
3715 if (!NILP (replace
) && ! replace_handled
&& BEGV
< ZV
)
3717 EMACS_INT same_at_start
= BEGV_BYTE
;
3718 EMACS_INT same_at_end
= ZV_BYTE
;
3719 EMACS_INT same_at_start_charpos
;
3720 EMACS_INT inserted_chars
;
3723 unsigned char *decoded
;
3725 int this_count
= SPECPDL_INDEX ();
3726 int multibyte
= ! NILP (current_buffer
->enable_multibyte_characters
);
3727 Lisp_Object conversion_buffer
;
3729 conversion_buffer
= code_conversion_save (1, multibyte
);
3731 /* First read the whole file, performing code conversion into
3732 CONVERSION_BUFFER. */
3734 if (lseek (fd
, XINT (beg
), 0) < 0)
3735 report_file_error ("Setting file position",
3736 Fcons (orig_filename
, Qnil
));
3738 total
= st
.st_size
; /* Total bytes in the file. */
3739 how_much
= 0; /* Bytes read from file so far. */
3740 inserted
= 0; /* Bytes put into CONVERSION_BUFFER so far. */
3741 unprocessed
= 0; /* Bytes not processed in previous loop. */
3743 GCPRO1 (conversion_buffer
);
3744 while (how_much
< total
)
3746 /* We read one bunch by one (READ_BUF_SIZE bytes) to allow
3747 quitting while reading a huge while. */
3748 /* try is reserved in some compilers (Microsoft C) */
3749 EMACS_INT trytry
= min (total
- how_much
,
3750 READ_BUF_SIZE
- unprocessed
);
3753 /* Allow quitting out of the actual I/O. */
3756 this = emacs_read (fd
, read_buf
+ unprocessed
, trytry
);
3768 BUF_TEMP_SET_PT (XBUFFER (conversion_buffer
),
3769 BUF_Z (XBUFFER (conversion_buffer
)));
3770 decode_coding_c_string (&coding
, read_buf
, unprocessed
+ this,
3772 unprocessed
= coding
.carryover_bytes
;
3773 if (coding
.carryover_bytes
> 0)
3774 memcpy (read_buf
, coding
.carryover
, unprocessed
);
3779 /* We should remove the unwind_protect calling
3780 close_file_unwind, but other stuff has been added the stack,
3781 so defer the removal till we reach the `handled' label. */
3782 deferred_remove_unwind_protect
= 1;
3784 /* At this point, HOW_MUCH should equal TOTAL, or should be <= 0
3785 if we couldn't read the file. */
3788 error ("IO error reading %s: %s",
3789 SDATA (orig_filename
), emacs_strerror (errno
));
3791 if (unprocessed
> 0)
3793 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
3794 decode_coding_c_string (&coding
, read_buf
, unprocessed
,
3796 coding
.mode
&= ~CODING_MODE_LAST_BLOCK
;
3799 coding_system
= CODING_ID_NAME (coding
.id
);
3800 set_coding_system
= 1;
3801 decoded
= BUF_BEG_ADDR (XBUFFER (conversion_buffer
));
3802 inserted
= (BUF_Z_BYTE (XBUFFER (conversion_buffer
))
3803 - BUF_BEG_BYTE (XBUFFER (conversion_buffer
)));
3805 /* Compare the beginning of the converted string with the buffer
3809 while (bufpos
< inserted
&& same_at_start
< same_at_end
3810 && FETCH_BYTE (same_at_start
) == decoded
[bufpos
])
3811 same_at_start
++, bufpos
++;
3813 /* If the file matches the head of buffer completely,
3814 there's no need to replace anything. */
3816 if (bufpos
== inserted
)
3818 /* Truncate the buffer to the size of the file. */
3819 if (same_at_start
== same_at_end
)
3822 del_range_byte (same_at_start
, same_at_end
, 0);
3825 unbind_to (this_count
, Qnil
);
3829 /* Extend the start of non-matching text area to the previous
3830 multibyte character boundary. */
3831 if (! NILP (current_buffer
->enable_multibyte_characters
))
3832 while (same_at_start
> BEGV_BYTE
3833 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_start
)))
3836 /* Scan this bufferful from the end, comparing with
3837 the Emacs buffer. */
3840 /* Compare with same_at_start to avoid counting some buffer text
3841 as matching both at the file's beginning and at the end. */
3842 while (bufpos
> 0 && same_at_end
> same_at_start
3843 && FETCH_BYTE (same_at_end
- 1) == decoded
[bufpos
- 1])
3844 same_at_end
--, bufpos
--;
3846 /* Extend the end of non-matching text area to the next
3847 multibyte character boundary. */
3848 if (! NILP (current_buffer
->enable_multibyte_characters
))
3849 while (same_at_end
< ZV_BYTE
3850 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_end
)))
3853 /* Don't try to reuse the same piece of text twice. */
3854 overlap
= same_at_start
- BEGV_BYTE
- (same_at_end
+ inserted
- ZV_BYTE
);
3856 same_at_end
+= overlap
;
3858 /* If display currently starts at beginning of line,
3859 keep it that way. */
3860 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3861 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3863 /* Replace the chars that we need to replace,
3864 and update INSERTED to equal the number of bytes
3865 we are taking from the decoded string. */
3866 inserted
-= (ZV_BYTE
- same_at_end
) + (same_at_start
- BEGV_BYTE
);
3868 if (same_at_end
!= same_at_start
)
3870 del_range_byte (same_at_start
, same_at_end
, 0);
3872 same_at_start
= GPT_BYTE
;
3876 temp
= BYTE_TO_CHAR (same_at_start
);
3878 /* Insert from the file at the proper position. */
3879 SET_PT_BOTH (temp
, same_at_start
);
3880 same_at_start_charpos
3881 = buf_bytepos_to_charpos (XBUFFER (conversion_buffer
),
3882 same_at_start
- BEGV_BYTE
3883 + BUF_BEG_BYTE (XBUFFER (conversion_buffer
)));
3885 = (buf_bytepos_to_charpos (XBUFFER (conversion_buffer
),
3886 same_at_start
+ inserted
- BEGV_BYTE
3887 + BUF_BEG_BYTE (XBUFFER (conversion_buffer
)))
3888 - same_at_start_charpos
);
3889 /* This binding is to avoid ask-user-about-supersession-threat
3890 being called in insert_from_buffer (via in
3891 prepare_to_modify_buffer). */
3892 specbind (intern ("buffer-file-name"), Qnil
);
3893 insert_from_buffer (XBUFFER (conversion_buffer
),
3894 same_at_start_charpos
, inserted_chars
, 0);
3895 /* Set `inserted' to the number of inserted characters. */
3896 inserted
= PT
- temp
;
3897 /* Set point before the inserted characters. */
3898 SET_PT_BOTH (temp
, same_at_start
);
3900 unbind_to (this_count
, Qnil
);
3907 register Lisp_Object temp
;
3909 total
= XINT (end
) - XINT (beg
);
3911 /* Make sure point-max won't overflow after this insertion. */
3912 XSETINT (temp
, total
);
3913 if (total
!= XINT (temp
))
3914 error ("Maximum buffer size exceeded");
3917 /* For a special file, all we can do is guess. */
3918 total
= READ_BUF_SIZE
;
3920 if (NILP (visit
) && inserted
> 0)
3922 #ifdef CLASH_DETECTION
3923 if (!NILP (current_buffer
->file_truename
)
3924 /* Make binding buffer-file-name to nil effective. */
3925 && !NILP (current_buffer
->filename
)
3926 && SAVE_MODIFF
>= MODIFF
)
3928 #endif /* CLASH_DETECTION */
3929 prepare_to_modify_buffer (GPT
, GPT
, NULL
);
3933 if (GAP_SIZE
< total
)
3934 make_gap (total
- GAP_SIZE
);
3936 if (XINT (beg
) != 0 || !NILP (replace
))
3938 if (lseek (fd
, XINT (beg
), 0) < 0)
3939 report_file_error ("Setting file position",
3940 Fcons (orig_filename
, Qnil
));
3943 /* In the following loop, HOW_MUCH contains the total bytes read so
3944 far for a regular file, and not changed for a special file. But,
3945 before exiting the loop, it is set to a negative value if I/O
3949 /* Total bytes inserted. */
3952 /* Here, we don't do code conversion in the loop. It is done by
3953 decode_coding_gap after all data are read into the buffer. */
3955 EMACS_INT gap_size
= GAP_SIZE
;
3957 while (how_much
< total
)
3959 /* try is reserved in some compilers (Microsoft C) */
3960 EMACS_INT trytry
= min (total
- how_much
, READ_BUF_SIZE
);
3967 /* Maybe make more room. */
3968 if (gap_size
< trytry
)
3970 make_gap (total
- gap_size
);
3971 gap_size
= GAP_SIZE
;
3974 /* Read from the file, capturing `quit'. When an
3975 error occurs, end the loop, and arrange for a quit
3976 to be signaled after decoding the text we read. */
3977 non_regular_fd
= fd
;
3978 non_regular_inserted
= inserted
;
3979 non_regular_nbytes
= trytry
;
3980 val
= internal_condition_case_1 (read_non_regular
, Qnil
, Qerror
,
3981 read_non_regular_quit
);
3992 /* Allow quitting out of the actual I/O. We don't make text
3993 part of the buffer until all the reading is done, so a C-g
3994 here doesn't do any harm. */
3997 this = emacs_read (fd
, BEG_ADDR
+ PT_BYTE
- BEG_BYTE
+ inserted
, trytry
);
4009 /* For a regular file, where TOTAL is the real size,
4010 count HOW_MUCH to compare with it.
4011 For a special file, where TOTAL is just a buffer size,
4012 so don't bother counting in HOW_MUCH.
4013 (INSERTED is where we count the number of characters inserted.) */
4020 /* Now we have read all the file data into the gap.
4021 If it was empty, undo marking the buffer modified. */
4025 #ifdef CLASH_DETECTION
4027 unlock_file (current_buffer
->file_truename
);
4029 Vdeactivate_mark
= old_Vdeactivate_mark
;
4032 Vdeactivate_mark
= Qt
;
4034 /* Make the text read part of the buffer. */
4035 GAP_SIZE
-= inserted
;
4037 GPT_BYTE
+= inserted
;
4039 ZV_BYTE
+= inserted
;
4044 /* Put an anchor to ensure multi-byte form ends at gap. */
4049 /* Discard the unwind protect for closing the file. */
4053 error ("IO error reading %s: %s",
4054 SDATA (orig_filename
), emacs_strerror (errno
));
4058 if (NILP (coding_system
))
4060 /* The coding system is not yet decided. Decide it by an
4061 optimized method for handling `coding:' tag.
4063 Note that we can get here only if the buffer was empty
4064 before the insertion. */
4066 if (!NILP (Vcoding_system_for_read
))
4067 coding_system
= Vcoding_system_for_read
;
4070 /* Since we are sure that the current buffer was empty
4071 before the insertion, we can toggle
4072 enable-multibyte-characters directly here without taking
4073 care of marker adjustment. By this way, we can run Lisp
4074 program safely before decoding the inserted text. */
4075 Lisp_Object unwind_data
;
4076 int count
= SPECPDL_INDEX ();
4078 unwind_data
= Fcons (current_buffer
->enable_multibyte_characters
,
4079 Fcons (current_buffer
->undo_list
,
4080 Fcurrent_buffer ()));
4081 current_buffer
->enable_multibyte_characters
= Qnil
;
4082 current_buffer
->undo_list
= Qt
;
4083 record_unwind_protect (decide_coding_unwind
, unwind_data
);
4085 if (inserted
> 0 && ! NILP (Vset_auto_coding_function
))
4087 coding_system
= call2 (Vset_auto_coding_function
,
4088 filename
, make_number (inserted
));
4091 if (NILP (coding_system
))
4093 /* If the coding system is not yet decided, check
4094 file-coding-system-alist. */
4095 Lisp_Object args
[6];
4097 args
[0] = Qinsert_file_contents
, args
[1] = orig_filename
;
4098 args
[2] = visit
, args
[3] = beg
, args
[4] = end
, args
[5] = Qnil
;
4099 coding_system
= Ffind_operation_coding_system (6, args
);
4100 if (CONSP (coding_system
))
4101 coding_system
= XCAR (coding_system
);
4103 unbind_to (count
, Qnil
);
4104 inserted
= Z_BYTE
- BEG_BYTE
;
4107 if (NILP (coding_system
))
4108 coding_system
= Qundecided
;
4110 CHECK_CODING_SYSTEM (coding_system
);
4112 if (NILP (current_buffer
->enable_multibyte_characters
))
4113 /* We must suppress all character code conversion except for
4114 end-of-line conversion. */
4115 coding_system
= raw_text_coding_system (coding_system
);
4116 setup_coding_system (coding_system
, &coding
);
4117 /* Ensure we set Vlast_coding_system_used. */
4118 set_coding_system
= 1;
4123 /* When we visit a file by raw-text, we change the buffer to
4125 if (CODING_FOR_UNIBYTE (&coding
)
4126 /* Can't do this if part of the buffer might be preserved. */
4128 /* Visiting a file with these coding system makes the buffer
4130 current_buffer
->enable_multibyte_characters
= Qnil
;
4133 coding
.dst_multibyte
= ! NILP (current_buffer
->enable_multibyte_characters
);
4134 if (CODING_MAY_REQUIRE_DECODING (&coding
)
4135 && (inserted
> 0 || CODING_REQUIRE_FLUSHING (&coding
)))
4137 move_gap_both (PT
, PT_BYTE
);
4138 GAP_SIZE
+= inserted
;
4139 ZV_BYTE
-= inserted
;
4143 decode_coding_gap (&coding
, inserted
, inserted
);
4144 inserted
= coding
.produced_char
;
4145 coding_system
= CODING_ID_NAME (coding
.id
);
4147 else if (inserted
> 0)
4148 adjust_after_insert (PT
, PT_BYTE
, PT
+ inserted
, PT_BYTE
+ inserted
,
4151 /* Now INSERTED is measured in characters. */
4154 /* Use the conversion type to determine buffer-file-type
4155 (find-buffer-file-type is now used to help determine the
4157 if ((VECTORP (CODING_ID_EOL_TYPE (coding
.id
))
4158 || EQ (CODING_ID_EOL_TYPE (coding
.id
), Qunix
))
4159 && ! CODING_REQUIRE_DECODING (&coding
))
4160 current_buffer
->buffer_file_type
= Qt
;
4162 current_buffer
->buffer_file_type
= Qnil
;
4167 if (deferred_remove_unwind_protect
)
4168 /* If requested above, discard the unwind protect for closing the
4174 if (!EQ (current_buffer
->undo_list
, Qt
) && !nochange
)
4175 current_buffer
->undo_list
= Qnil
;
4179 current_buffer
->modtime
= st
.st_mtime
;
4180 current_buffer
->modtime_size
= st
.st_size
;
4181 current_buffer
->filename
= orig_filename
;
4184 SAVE_MODIFF
= MODIFF
;
4185 BUF_AUTOSAVE_MODIFF (current_buffer
) = MODIFF
;
4186 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4187 #ifdef CLASH_DETECTION
4190 if (!NILP (current_buffer
->file_truename
))
4191 unlock_file (current_buffer
->file_truename
);
4192 unlock_file (filename
);
4194 #endif /* CLASH_DETECTION */
4196 xsignal2 (Qfile_error
,
4197 build_string ("not a regular file"), orig_filename
);
4200 if (set_coding_system
)
4201 Vlast_coding_system_used
= coding_system
;
4203 if (! NILP (Ffboundp (Qafter_insert_file_set_coding
)))
4205 insval
= call2 (Qafter_insert_file_set_coding
, make_number (inserted
),
4207 if (! NILP (insval
))
4209 CHECK_NUMBER (insval
);
4210 inserted
= XFASTINT (insval
);
4214 /* Decode file format. */
4217 /* Don't run point motion or modification hooks when decoding. */
4218 int count
= SPECPDL_INDEX ();
4219 EMACS_INT old_inserted
= inserted
;
4220 specbind (Qinhibit_point_motion_hooks
, Qt
);
4221 specbind (Qinhibit_modification_hooks
, Qt
);
4223 /* Save old undo list and don't record undo for decoding. */
4224 old_undo
= current_buffer
->undo_list
;
4225 current_buffer
->undo_list
= Qt
;
4229 insval
= call3 (Qformat_decode
,
4230 Qnil
, make_number (inserted
), visit
);
4231 CHECK_NUMBER (insval
);
4232 inserted
= XFASTINT (insval
);
4236 /* If REPLACE is non-nil and we succeeded in not replacing the
4237 beginning or end of the buffer text with the file's contents,
4238 call format-decode with `point' positioned at the beginning
4239 of the buffer and `inserted' equalling the number of
4240 characters in the buffer. Otherwise, format-decode might
4241 fail to correctly analyze the beginning or end of the buffer.
4242 Hence we temporarily save `point' and `inserted' here and
4243 restore `point' iff format-decode did not insert or delete
4244 any text. Otherwise we leave `point' at point-min. */
4245 EMACS_INT opoint
= PT
;
4246 EMACS_INT opoint_byte
= PT_BYTE
;
4247 EMACS_INT oinserted
= ZV
- BEGV
;
4248 int ochars_modiff
= CHARS_MODIFF
;
4250 TEMP_SET_PT_BOTH (BEGV
, BEGV_BYTE
);
4251 insval
= call3 (Qformat_decode
,
4252 Qnil
, make_number (oinserted
), visit
);
4253 CHECK_NUMBER (insval
);
4254 if (ochars_modiff
== CHARS_MODIFF
)
4255 /* format_decode didn't modify buffer's characters => move
4256 point back to position before inserted text and leave
4257 value of inserted alone. */
4258 SET_PT_BOTH (opoint
, opoint_byte
);
4260 /* format_decode modified buffer's characters => consider
4261 entire buffer changed and leave point at point-min. */
4262 inserted
= XFASTINT (insval
);
4265 /* For consistency with format-decode call these now iff inserted > 0
4266 (martin 2007-06-28). */
4267 p
= Vafter_insert_file_functions
;
4272 insval
= call1 (XCAR (p
), make_number (inserted
));
4275 CHECK_NUMBER (insval
);
4276 inserted
= XFASTINT (insval
);
4281 /* For the rationale of this see the comment on
4282 format-decode above. */
4283 EMACS_INT opoint
= PT
;
4284 EMACS_INT opoint_byte
= PT_BYTE
;
4285 EMACS_INT oinserted
= ZV
- BEGV
;
4286 int ochars_modiff
= CHARS_MODIFF
;
4288 TEMP_SET_PT_BOTH (BEGV
, BEGV_BYTE
);
4289 insval
= call1 (XCAR (p
), make_number (oinserted
));
4292 CHECK_NUMBER (insval
);
4293 if (ochars_modiff
== CHARS_MODIFF
)
4294 /* after_insert_file_functions didn't modify
4295 buffer's characters => move point back to
4296 position before inserted text and leave value of
4298 SET_PT_BOTH (opoint
, opoint_byte
);
4300 /* after_insert_file_functions did modify buffer's
4301 characters => consider entire buffer changed and
4302 leave point at point-min. */
4303 inserted
= XFASTINT (insval
);
4313 current_buffer
->undo_list
= old_undo
;
4314 if (CONSP (old_undo
) && inserted
!= old_inserted
)
4316 /* Adjust the last undo record for the size change during
4317 the format conversion. */
4318 Lisp_Object tem
= XCAR (old_undo
);
4319 if (CONSP (tem
) && INTEGERP (XCAR (tem
))
4320 && INTEGERP (XCDR (tem
))
4321 && XFASTINT (XCDR (tem
)) == PT
+ old_inserted
)
4322 XSETCDR (tem
, make_number (PT
+ inserted
));
4326 /* If undo_list was Qt before, keep it that way.
4327 Otherwise start with an empty undo_list. */
4328 current_buffer
->undo_list
= EQ (old_undo
, Qt
) ? Qt
: Qnil
;
4330 unbind_to (count
, Qnil
);
4333 /* Call after-change hooks for the inserted text, aside from the case
4334 of normal visiting (not with REPLACE), which is done in a new buffer
4335 "before" the buffer is changed. */
4336 if (inserted
> 0 && total
> 0
4337 && (NILP (visit
) || !NILP (replace
)))
4339 signal_after_change (PT
, 0, inserted
);
4340 update_compositions (PT
, PT
, CHECK_BORDER
);
4344 && current_buffer
->modtime
== -1)
4346 /* If visiting nonexistent file, return nil. */
4347 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
4351 Fsignal (Qquit
, Qnil
);
4353 /* ??? Retval needs to be dealt with in all cases consistently. */
4355 val
= Fcons (orig_filename
,
4356 Fcons (make_number (inserted
),
4359 RETURN_UNGCPRO (unbind_to (count
, val
));
4362 static Lisp_Object
build_annotations (Lisp_Object
, Lisp_Object
);
4365 build_annotations_unwind (Lisp_Object arg
)
4367 Vwrite_region_annotation_buffers
= arg
;
4371 /* Decide the coding-system to encode the data with. */
4374 choose_write_coding_system (Lisp_Object start
, Lisp_Object end
, Lisp_Object filename
,
4375 Lisp_Object append
, Lisp_Object visit
, Lisp_Object lockname
,
4376 struct coding_system
*coding
)
4379 Lisp_Object eol_parent
= Qnil
;
4382 && NILP (Fstring_equal (current_buffer
->filename
,
4383 current_buffer
->auto_save_file_name
)))
4388 else if (!NILP (Vcoding_system_for_write
))
4390 val
= Vcoding_system_for_write
;
4391 if (coding_system_require_warning
4392 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4393 /* Confirm that VAL can surely encode the current region. */
4394 val
= call5 (Vselect_safe_coding_system_function
,
4395 start
, end
, Fcons (Qt
, Fcons (val
, Qnil
)),
4400 /* If the variable `buffer-file-coding-system' is set locally,
4401 it means that the file was read with some kind of code
4402 conversion or the variable is explicitly set by users. We
4403 had better write it out with the same coding system even if
4404 `enable-multibyte-characters' is nil.
4406 If it is not set locally, we anyway have to convert EOL
4407 format if the default value of `buffer-file-coding-system'
4408 tells that it is not Unix-like (LF only) format. */
4409 int using_default_coding
= 0;
4410 int force_raw_text
= 0;
4412 val
= current_buffer
->buffer_file_coding_system
;
4414 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4417 if (NILP (current_buffer
->enable_multibyte_characters
))
4423 /* Check file-coding-system-alist. */
4424 Lisp_Object args
[7], coding_systems
;
4426 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4427 args
[3] = filename
; args
[4] = append
; args
[5] = visit
;
4429 coding_systems
= Ffind_operation_coding_system (7, args
);
4430 if (CONSP (coding_systems
) && !NILP (XCDR (coding_systems
)))
4431 val
= XCDR (coding_systems
);
4436 /* If we still have not decided a coding system, use the
4437 default value of buffer-file-coding-system. */
4438 val
= current_buffer
->buffer_file_coding_system
;
4439 using_default_coding
= 1;
4442 if (! NILP (val
) && ! force_raw_text
)
4444 Lisp_Object spec
, attrs
;
4446 CHECK_CODING_SYSTEM_GET_SPEC (val
, spec
);
4447 attrs
= AREF (spec
, 0);
4448 if (EQ (CODING_ATTR_TYPE (attrs
), Qraw_text
))
4453 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4454 /* Confirm that VAL can surely encode the current region. */
4455 val
= call5 (Vselect_safe_coding_system_function
,
4456 start
, end
, val
, Qnil
, filename
);
4458 /* If the decided coding-system doesn't specify end-of-line
4459 format, we use that of
4460 `default-buffer-file-coding-system'. */
4461 if (! using_default_coding
4462 && ! NILP (buffer_defaults
.buffer_file_coding_system
))
4463 val
= (coding_inherit_eol_type
4464 (val
, buffer_defaults
.buffer_file_coding_system
));
4466 /* If we decide not to encode text, use `raw-text' or one of its
4469 val
= raw_text_coding_system (val
);
4472 val
= coding_inherit_eol_type (val
, eol_parent
);
4473 setup_coding_system (val
, coding
);
4475 if (!STRINGP (start
) && !NILP (current_buffer
->selective_display
))
4476 coding
->mode
|= CODING_MODE_SELECTIVE_DISPLAY
;
4480 DEFUN ("write-region", Fwrite_region
, Swrite_region
, 3, 7,
4481 "r\nFWrite region to file: \ni\ni\ni\np",
4482 doc
: /* Write current region into specified file.
4483 When called from a program, requires three arguments:
4484 START, END and FILENAME. START and END are normally buffer positions
4485 specifying the part of the buffer to write.
4486 If START is nil, that means to use the entire buffer contents.
4487 If START is a string, then output that string to the file
4488 instead of any buffer contents; END is ignored.
4490 Optional fourth argument APPEND if non-nil means
4491 append to existing file contents (if any). If it is an integer,
4492 seek to that offset in the file before writing.
4493 Optional fifth argument VISIT, if t or a string, means
4494 set the last-save-file-modtime of buffer to this file's modtime
4495 and mark buffer not modified.
4496 If VISIT is a string, it is a second file name;
4497 the output goes to FILENAME, but the buffer is marked as visiting VISIT.
4498 VISIT is also the file name to lock and unlock for clash detection.
4499 If VISIT is neither t nor nil nor a string,
4500 that means do not display the \"Wrote file\" message.
4501 The optional sixth arg LOCKNAME, if non-nil, specifies the name to
4502 use for locking and unlocking, overriding FILENAME and VISIT.
4503 The optional seventh arg MUSTBENEW, if non-nil, insists on a check
4504 for an existing file with the same name. If MUSTBENEW is `excl',
4505 that means to get an error if the file already exists; never overwrite.
4506 If MUSTBENEW is neither nil nor `excl', that means ask for
4507 confirmation before overwriting, but do go ahead and overwrite the file
4508 if the user confirms.
4510 This does code conversion according to the value of
4511 `coding-system-for-write', `buffer-file-coding-system', or
4512 `file-coding-system-alist', and sets the variable
4513 `last-coding-system-used' to the coding system actually used.
4515 This calls `write-region-annotate-functions' at the start, and
4516 `write-region-post-annotation-function' at the end. */)
4517 (Lisp_Object start
, Lisp_Object end
, Lisp_Object filename
, Lisp_Object append
, Lisp_Object visit
, Lisp_Object lockname
, Lisp_Object mustbenew
)
4522 const unsigned char *fn
;
4524 int count
= SPECPDL_INDEX ();
4526 Lisp_Object handler
;
4527 Lisp_Object visit_file
;
4528 Lisp_Object annotations
;
4529 Lisp_Object encoded_filename
;
4530 int visiting
= (EQ (visit
, Qt
) || STRINGP (visit
));
4531 int quietly
= !NILP (visit
);
4532 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
4533 struct buffer
*given_buffer
;
4535 int buffer_file_type
= O_BINARY
;
4537 struct coding_system coding
;
4539 if (current_buffer
->base_buffer
&& visiting
)
4540 error ("Cannot do file visiting in an indirect buffer");
4542 if (!NILP (start
) && !STRINGP (start
))
4543 validate_region (&start
, &end
);
4546 GCPRO5 (start
, filename
, visit
, visit_file
, lockname
);
4548 filename
= Fexpand_file_name (filename
, Qnil
);
4550 if (!NILP (mustbenew
) && !EQ (mustbenew
, Qexcl
))
4551 barf_or_query_if_file_exists (filename
, "overwrite", 1, 0, 1);
4553 if (STRINGP (visit
))
4554 visit_file
= Fexpand_file_name (visit
, Qnil
);
4556 visit_file
= filename
;
4558 if (NILP (lockname
))
4559 lockname
= visit_file
;
4563 /* If the file name has special constructs in it,
4564 call the corresponding file handler. */
4565 handler
= Ffind_file_name_handler (filename
, Qwrite_region
);
4566 /* If FILENAME has no handler, see if VISIT has one. */
4567 if (NILP (handler
) && STRINGP (visit
))
4568 handler
= Ffind_file_name_handler (visit
, Qwrite_region
);
4570 if (!NILP (handler
))
4573 val
= call6 (handler
, Qwrite_region
, start
, end
,
4574 filename
, append
, visit
);
4578 SAVE_MODIFF
= MODIFF
;
4579 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4580 current_buffer
->filename
= visit_file
;
4586 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
4588 /* Special kludge to simplify auto-saving. */
4591 /* Do it later, so write-region-annotate-function can work differently
4592 if we save "the buffer" vs "a region".
4593 This is useful in tar-mode. --Stef
4594 XSETFASTINT (start, BEG);
4595 XSETFASTINT (end, Z); */
4599 record_unwind_protect (build_annotations_unwind
,
4600 Vwrite_region_annotation_buffers
);
4601 Vwrite_region_annotation_buffers
= Fcons (Fcurrent_buffer (), Qnil
);
4602 count1
= SPECPDL_INDEX ();
4604 given_buffer
= current_buffer
;
4606 if (!STRINGP (start
))
4608 annotations
= build_annotations (start
, end
);
4610 if (current_buffer
!= given_buffer
)
4612 XSETFASTINT (start
, BEGV
);
4613 XSETFASTINT (end
, ZV
);
4619 XSETFASTINT (start
, BEGV
);
4620 XSETFASTINT (end
, ZV
);
4625 GCPRO5 (start
, filename
, annotations
, visit_file
, lockname
);
4627 /* Decide the coding-system to encode the data with.
4628 We used to make this choice before calling build_annotations, but that
4629 leads to problems when a write-annotate-function takes care of
4630 unsavable chars (as was the case with X-Symbol). */
4631 Vlast_coding_system_used
4632 = choose_write_coding_system (start
, end
, filename
,
4633 append
, visit
, lockname
, &coding
);
4635 #ifdef CLASH_DETECTION
4637 lock_file (lockname
);
4638 #endif /* CLASH_DETECTION */
4640 encoded_filename
= ENCODE_FILE (filename
);
4642 fn
= SDATA (encoded_filename
);
4646 desc
= emacs_open (fn
, O_WRONLY
| buffer_file_type
, 0);
4647 #else /* not DOS_NT */
4648 desc
= emacs_open (fn
, O_WRONLY
, 0);
4649 #endif /* not DOS_NT */
4651 if (desc
< 0 && (NILP (append
) || errno
== ENOENT
))
4653 desc
= emacs_open (fn
,
4654 O_WRONLY
| O_CREAT
| buffer_file_type
4655 | (EQ (mustbenew
, Qexcl
) ? O_EXCL
: O_TRUNC
),
4656 S_IREAD
| S_IWRITE
);
4657 #else /* not DOS_NT */
4658 desc
= emacs_open (fn
, O_WRONLY
| O_TRUNC
| O_CREAT
4659 | (EQ (mustbenew
, Qexcl
) ? O_EXCL
: 0),
4660 auto_saving
? auto_save_mode_bits
: 0666);
4661 #endif /* not DOS_NT */
4665 #ifdef CLASH_DETECTION
4667 if (!auto_saving
) unlock_file (lockname
);
4669 #endif /* CLASH_DETECTION */
4671 report_file_error ("Opening output file", Fcons (filename
, Qnil
));
4674 record_unwind_protect (close_file_unwind
, make_number (desc
));
4676 if (!NILP (append
) && !NILP (Ffile_regular_p (filename
)))
4680 if (NUMBERP (append
))
4681 ret
= lseek (desc
, XINT (append
), 1);
4683 ret
= lseek (desc
, 0, 2);
4686 #ifdef CLASH_DETECTION
4687 if (!auto_saving
) unlock_file (lockname
);
4688 #endif /* CLASH_DETECTION */
4690 report_file_error ("Lseek error", Fcons (filename
, Qnil
));
4699 if (STRINGP (start
))
4701 failure
= 0 > a_write (desc
, start
, 0, SCHARS (start
),
4702 &annotations
, &coding
);
4705 else if (XINT (start
) != XINT (end
))
4707 failure
= 0 > a_write (desc
, Qnil
,
4708 XINT (start
), XINT (end
) - XINT (start
),
4709 &annotations
, &coding
);
4714 /* If file was empty, still need to write the annotations */
4715 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4716 failure
= 0 > a_write (desc
, Qnil
, XINT (end
), 0, &annotations
, &coding
);
4720 if (CODING_REQUIRE_FLUSHING (&coding
)
4721 && !(coding
.mode
& CODING_MODE_LAST_BLOCK
)
4724 /* We have to flush out a data. */
4725 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4726 failure
= 0 > e_write (desc
, Qnil
, 1, 1, &coding
);
4733 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
4734 Disk full in NFS may be reported here. */
4735 /* mib says that closing the file will try to write as fast as NFS can do
4736 it, and that means the fsync here is not crucial for autosave files. */
4737 if (!auto_saving
&& !write_region_inhibit_fsync
&& fsync (desc
) < 0)
4739 /* If fsync fails with EINTR, don't treat that as serious. Also
4740 ignore EINVAL which happens when fsync is not supported on this
4742 if (errno
!= EINTR
&& errno
!= EINVAL
)
4743 failure
= 1, save_errno
= errno
;
4747 /* NFS can report a write failure now. */
4748 if (emacs_close (desc
) < 0)
4749 failure
= 1, save_errno
= errno
;
4753 /* Discard the unwind protect for close_file_unwind. */
4754 specpdl_ptr
= specpdl
+ count1
;
4756 /* Call write-region-post-annotation-function. */
4757 while (CONSP (Vwrite_region_annotation_buffers
))
4759 Lisp_Object buf
= XCAR (Vwrite_region_annotation_buffers
);
4760 if (!NILP (Fbuffer_live_p (buf
)))
4763 if (FUNCTIONP (Vwrite_region_post_annotation_function
))
4764 call0 (Vwrite_region_post_annotation_function
);
4766 Vwrite_region_annotation_buffers
4767 = XCDR (Vwrite_region_annotation_buffers
);
4770 unbind_to (count
, Qnil
);
4772 #ifdef CLASH_DETECTION
4774 unlock_file (lockname
);
4775 #endif /* CLASH_DETECTION */
4777 /* Do this before reporting IO error
4778 to avoid a "file has changed on disk" warning on
4779 next attempt to save. */
4782 current_buffer
->modtime
= st
.st_mtime
;
4783 current_buffer
->modtime_size
= st
.st_size
;
4787 error ("IO error writing %s: %s", SDATA (filename
),
4788 emacs_strerror (save_errno
));
4792 SAVE_MODIFF
= MODIFF
;
4793 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4794 current_buffer
->filename
= visit_file
;
4795 update_mode_lines
++;
4800 && ! NILP (Fstring_equal (current_buffer
->filename
,
4801 current_buffer
->auto_save_file_name
)))
4802 SAVE_MODIFF
= MODIFF
;
4808 message_with_string ((INTEGERP (append
)
4818 Lisp_Object
merge (Lisp_Object
, Lisp_Object
, Lisp_Object
);
4820 DEFUN ("car-less-than-car", Fcar_less_than_car
, Scar_less_than_car
, 2, 2, 0,
4821 doc
: /* Return t if (car A) is numerically less than (car B). */)
4822 (Lisp_Object a
, Lisp_Object b
)
4824 return Flss (Fcar (a
), Fcar (b
));
4827 /* Build the complete list of annotations appropriate for writing out
4828 the text between START and END, by calling all the functions in
4829 write-region-annotate-functions and merging the lists they return.
4830 If one of these functions switches to a different buffer, we assume
4831 that buffer contains altered text. Therefore, the caller must
4832 make sure to restore the current buffer in all cases,
4833 as save-excursion would do. */
4836 build_annotations (Lisp_Object start
, Lisp_Object end
)
4838 Lisp_Object annotations
;
4840 struct gcpro gcpro1
, gcpro2
;
4841 Lisp_Object original_buffer
;
4842 int i
, used_global
= 0;
4844 XSETBUFFER (original_buffer
, current_buffer
);
4847 p
= Vwrite_region_annotate_functions
;
4848 GCPRO2 (annotations
, p
);
4851 struct buffer
*given_buffer
= current_buffer
;
4852 if (EQ (Qt
, XCAR (p
)) && !used_global
)
4853 { /* Use the global value of the hook. */
4856 arg
[0] = Fdefault_value (Qwrite_region_annotate_functions
);
4858 p
= Fappend (2, arg
);
4861 Vwrite_region_annotations_so_far
= annotations
;
4862 res
= call2 (XCAR (p
), start
, end
);
4863 /* If the function makes a different buffer current,
4864 assume that means this buffer contains altered text to be output.
4865 Reset START and END from the buffer bounds
4866 and discard all previous annotations because they should have
4867 been dealt with by this function. */
4868 if (current_buffer
!= given_buffer
)
4870 Vwrite_region_annotation_buffers
4871 = Fcons (Fcurrent_buffer (),
4872 Vwrite_region_annotation_buffers
);
4873 XSETFASTINT (start
, BEGV
);
4874 XSETFASTINT (end
, ZV
);
4877 Flength (res
); /* Check basic validity of return value */
4878 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
4882 /* Now do the same for annotation functions implied by the file-format */
4883 if (auto_saving
&& (!EQ (current_buffer
->auto_save_file_format
, Qt
)))
4884 p
= current_buffer
->auto_save_file_format
;
4886 p
= current_buffer
->file_format
;
4887 for (i
= 0; CONSP (p
); p
= XCDR (p
), ++i
)
4889 struct buffer
*given_buffer
= current_buffer
;
4891 Vwrite_region_annotations_so_far
= annotations
;
4893 /* Value is either a list of annotations or nil if the function
4894 has written annotations to a temporary buffer, which is now
4896 res
= call5 (Qformat_annotate_function
, XCAR (p
), start
, end
,
4897 original_buffer
, make_number (i
));
4898 if (current_buffer
!= given_buffer
)
4900 XSETFASTINT (start
, BEGV
);
4901 XSETFASTINT (end
, ZV
);
4906 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
4914 /* Write to descriptor DESC the NCHARS chars starting at POS of STRING.
4915 If STRING is nil, POS is the character position in the current buffer.
4916 Intersperse with them the annotations from *ANNOT
4917 which fall within the range of POS to POS + NCHARS,
4918 each at its appropriate position.
4920 We modify *ANNOT by discarding elements as we use them up.
4922 The return value is negative in case of system call failure. */
4925 a_write (int desc
, Lisp_Object string
, int pos
, register int nchars
, Lisp_Object
*annot
, struct coding_system
*coding
)
4929 int lastpos
= pos
+ nchars
;
4931 while (NILP (*annot
) || CONSP (*annot
))
4933 tem
= Fcar_safe (Fcar (*annot
));
4936 nextpos
= XFASTINT (tem
);
4938 /* If there are no more annotations in this range,
4939 output the rest of the range all at once. */
4940 if (! (nextpos
>= pos
&& nextpos
<= lastpos
))
4941 return e_write (desc
, string
, pos
, lastpos
, coding
);
4943 /* Output buffer text up to the next annotation's position. */
4946 if (0 > e_write (desc
, string
, pos
, nextpos
, coding
))
4950 /* Output the annotation. */
4951 tem
= Fcdr (Fcar (*annot
));
4954 if (0 > e_write (desc
, tem
, 0, SCHARS (tem
), coding
))
4957 *annot
= Fcdr (*annot
);
4963 /* Write text in the range START and END into descriptor DESC,
4964 encoding them with coding system CODING. If STRING is nil, START
4965 and END are character positions of the current buffer, else they
4966 are indexes to the string STRING. */
4969 e_write (int desc
, Lisp_Object string
, int start
, int end
, struct coding_system
*coding
)
4971 if (STRINGP (string
))
4974 end
= SCHARS (string
);
4977 /* We used to have a code for handling selective display here. But,
4978 now it is handled within encode_coding. */
4982 if (STRINGP (string
))
4984 coding
->src_multibyte
= SCHARS (string
) < SBYTES (string
);
4985 if (CODING_REQUIRE_ENCODING (coding
))
4987 encode_coding_object (coding
, string
,
4988 start
, string_char_to_byte (string
, start
),
4989 end
, string_char_to_byte (string
, end
), Qt
);
4993 coding
->dst_object
= string
;
4994 coding
->consumed_char
= SCHARS (string
);
4995 coding
->produced
= SBYTES (string
);
5000 int start_byte
= CHAR_TO_BYTE (start
);
5001 int end_byte
= CHAR_TO_BYTE (end
);
5003 coding
->src_multibyte
= (end
- start
) < (end_byte
- start_byte
);
5004 if (CODING_REQUIRE_ENCODING (coding
))
5006 encode_coding_object (coding
, Fcurrent_buffer (),
5007 start
, start_byte
, end
, end_byte
, Qt
);
5011 coding
->dst_object
= Qnil
;
5012 coding
->dst_pos_byte
= start_byte
;
5013 if (start
>= GPT
|| end
<= GPT
)
5015 coding
->consumed_char
= end
- start
;
5016 coding
->produced
= end_byte
- start_byte
;
5020 coding
->consumed_char
= GPT
- start
;
5021 coding
->produced
= GPT_BYTE
- start_byte
;
5026 if (coding
->produced
> 0)
5030 STRINGP (coding
->dst_object
)
5031 ? SDATA (coding
->dst_object
)
5032 : BYTE_POS_ADDR (coding
->dst_pos_byte
),
5035 if (coding
->produced
)
5038 start
+= coding
->consumed_char
;
5044 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime
,
5045 Sverify_visited_file_modtime
, 0, 1, 0,
5046 doc
: /* Return t if last mod time of BUF's visited file matches what BUF records.
5047 This means that the file has not been changed since it was visited or saved.
5048 If BUF is omitted or nil, it defaults to the current buffer.
5049 See Info node `(elisp)Modification Time' for more details. */)
5054 Lisp_Object handler
;
5055 Lisp_Object filename
;
5065 if (!STRINGP (b
->filename
)) return Qt
;
5066 if (b
->modtime
== 0) return Qt
;
5068 /* If the file name has special constructs in it,
5069 call the corresponding file handler. */
5070 handler
= Ffind_file_name_handler (b
->filename
,
5071 Qverify_visited_file_modtime
);
5072 if (!NILP (handler
))
5073 return call2 (handler
, Qverify_visited_file_modtime
, buf
);
5075 filename
= ENCODE_FILE (b
->filename
);
5077 if (stat (SDATA (filename
), &st
) < 0)
5079 /* If the file doesn't exist now and didn't exist before,
5080 we say that it isn't modified, provided the error is a tame one. */
5081 if (errno
== ENOENT
|| errno
== EACCES
|| errno
== ENOTDIR
)
5086 if ((st
.st_mtime
== b
->modtime
5087 /* If both are positive, accept them if they are off by one second. */
5088 || (st
.st_mtime
> 0 && b
->modtime
> 0
5089 && (st
.st_mtime
== b
->modtime
+ 1
5090 || st
.st_mtime
== b
->modtime
- 1)))
5091 && (st
.st_size
== b
->modtime_size
5092 || b
->modtime_size
< 0))
5097 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime
,
5098 Sclear_visited_file_modtime
, 0, 0, 0,
5099 doc
: /* Clear out records of last mod time of visited file.
5100 Next attempt to save will certainly not complain of a discrepancy. */)
5103 current_buffer
->modtime
= 0;
5104 current_buffer
->modtime_size
= -1;
5108 DEFUN ("visited-file-modtime", Fvisited_file_modtime
,
5109 Svisited_file_modtime
, 0, 0, 0,
5110 doc
: /* Return the current buffer's recorded visited file modification time.
5111 The value is a list of the form (HIGH LOW), like the time values
5112 that `file-attributes' returns. If the current buffer has no recorded
5113 file modification time, this function returns 0.
5114 See Info node `(elisp)Modification Time' for more details. */)
5117 if (! current_buffer
->modtime
)
5118 return make_number (0);
5119 return make_time ((time_t) current_buffer
->modtime
);
5122 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime
,
5123 Sset_visited_file_modtime
, 0, 1, 0,
5124 doc
: /* Update buffer's recorded modification time from the visited file's time.
5125 Useful if the buffer was not read from the file normally
5126 or if the file itself has been changed for some known benign reason.
5127 An argument specifies the modification time value to use
5128 \(instead of that of the visited file), in the form of a list
5129 \(HIGH . LOW) or (HIGH LOW). */)
5130 (Lisp_Object time_list
)
5132 if (!NILP (time_list
))
5134 current_buffer
->modtime
= cons_to_long (time_list
);
5135 current_buffer
->modtime_size
= -1;
5139 register Lisp_Object filename
;
5141 Lisp_Object handler
;
5143 filename
= Fexpand_file_name (current_buffer
->filename
, Qnil
);
5145 /* If the file name has special constructs in it,
5146 call the corresponding file handler. */
5147 handler
= Ffind_file_name_handler (filename
, Qset_visited_file_modtime
);
5148 if (!NILP (handler
))
5149 /* The handler can find the file name the same way we did. */
5150 return call2 (handler
, Qset_visited_file_modtime
, Qnil
);
5152 filename
= ENCODE_FILE (filename
);
5154 if (stat (SDATA (filename
), &st
) >= 0)
5156 current_buffer
->modtime
= st
.st_mtime
;
5157 current_buffer
->modtime_size
= st
.st_size
;
5165 auto_save_error (Lisp_Object error
)
5167 Lisp_Object args
[3], msg
;
5169 struct gcpro gcpro1
;
5173 auto_save_error_occurred
= 1;
5175 ring_bell (XFRAME (selected_frame
));
5177 args
[0] = build_string ("Auto-saving %s: %s");
5178 args
[1] = current_buffer
->name
;
5179 args
[2] = Ferror_message_string (error
);
5180 msg
= Fformat (3, args
);
5182 nbytes
= SBYTES (msg
);
5183 SAFE_ALLOCA (msgbuf
, char *, nbytes
);
5184 memcpy (msgbuf
, SDATA (msg
), nbytes
);
5186 for (i
= 0; i
< 3; ++i
)
5189 message2 (msgbuf
, nbytes
, STRING_MULTIBYTE (msg
));
5191 message2_nolog (msgbuf
, nbytes
, STRING_MULTIBYTE (msg
));
5192 Fsleep_for (make_number (1), Qnil
);
5206 auto_save_mode_bits
= 0666;
5208 /* Get visited file's mode to become the auto save file's mode. */
5209 if (! NILP (current_buffer
->filename
))
5211 if (stat (SDATA (current_buffer
->filename
), &st
) >= 0)
5212 /* But make sure we can overwrite it later! */
5213 auto_save_mode_bits
= st
.st_mode
| 0600;
5214 else if ((modes
= Ffile_modes (current_buffer
->filename
),
5216 /* Remote files don't cooperate with stat. */
5217 auto_save_mode_bits
= XINT (modes
) | 0600;
5221 Fwrite_region (Qnil
, Qnil
, current_buffer
->auto_save_file_name
, Qnil
,
5222 NILP (Vauto_save_visited_file_name
) ? Qlambda
: Qt
,
5227 do_auto_save_unwind (Lisp_Object arg
) /* used as unwind-protect function */
5230 FILE *stream
= (FILE *) XSAVE_VALUE (arg
)->pointer
;
5242 do_auto_save_unwind_1 (Lisp_Object value
) /* used as unwind-protect function */
5245 minibuffer_auto_raise
= XINT (value
);
5250 do_auto_save_make_dir (Lisp_Object dir
)
5254 call2 (Qmake_directory
, dir
, Qt
);
5255 XSETFASTINT (mode
, 0700);
5256 return Fset_file_modes (dir
, mode
);
5260 do_auto_save_eh (Lisp_Object ignore
)
5265 DEFUN ("do-auto-save", Fdo_auto_save
, Sdo_auto_save
, 0, 2, "",
5266 doc
: /* Auto-save all buffers that need it.
5267 This is all buffers that have auto-saving enabled
5268 and are changed since last auto-saved.
5269 Auto-saving writes the buffer into a file
5270 so that your editing is not lost if the system crashes.
5271 This file is not the file you visited; that changes only when you save.
5272 Normally we run the normal hook `auto-save-hook' before saving.
5274 A non-nil NO-MESSAGE argument means do not print any message if successful.
5275 A non-nil CURRENT-ONLY argument means save only current buffer. */)
5276 (Lisp_Object no_message
, Lisp_Object current_only
)
5278 struct buffer
*old
= current_buffer
, *b
;
5279 Lisp_Object tail
, buf
;
5281 int do_handled_files
;
5283 FILE *stream
= NULL
;
5284 int count
= SPECPDL_INDEX ();
5285 int orig_minibuffer_auto_raise
= minibuffer_auto_raise
;
5286 int old_message_p
= 0;
5287 struct gcpro gcpro1
, gcpro2
;
5289 if (max_specpdl_size
< specpdl_size
+ 40)
5290 max_specpdl_size
= specpdl_size
+ 40;
5295 if (NILP (no_message
))
5297 old_message_p
= push_message ();
5298 record_unwind_protect (pop_message_unwind
, Qnil
);
5301 /* Ordinarily don't quit within this function,
5302 but don't make it impossible to quit (in case we get hung in I/O). */
5306 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
5307 point to non-strings reached from Vbuffer_alist. */
5309 if (!NILP (Vrun_hooks
))
5310 call1 (Vrun_hooks
, intern ("auto-save-hook"));
5312 if (STRINGP (Vauto_save_list_file_name
))
5314 Lisp_Object listfile
;
5316 listfile
= Fexpand_file_name (Vauto_save_list_file_name
, Qnil
);
5318 /* Don't try to create the directory when shutting down Emacs,
5319 because creating the directory might signal an error, and
5320 that would leave Emacs in a strange state. */
5321 if (!NILP (Vrun_hooks
))
5325 GCPRO2 (dir
, listfile
);
5326 dir
= Ffile_name_directory (listfile
);
5327 if (NILP (Ffile_directory_p (dir
)))
5328 internal_condition_case_1 (do_auto_save_make_dir
,
5329 dir
, Fcons (Fcons (Qfile_error
, Qnil
), Qnil
),
5334 stream
= fopen (SDATA (listfile
), "w");
5337 record_unwind_protect (do_auto_save_unwind
,
5338 make_save_value (stream
, 0));
5339 record_unwind_protect (do_auto_save_unwind_1
,
5340 make_number (minibuffer_auto_raise
));
5341 minibuffer_auto_raise
= 0;
5343 auto_save_error_occurred
= 0;
5345 /* On first pass, save all files that don't have handlers.
5346 On second pass, save all files that do have handlers.
5348 If Emacs is crashing, the handlers may tweak what is causing
5349 Emacs to crash in the first place, and it would be a shame if
5350 Emacs failed to autosave perfectly ordinary files because it
5351 couldn't handle some ange-ftp'd file. */
5353 for (do_handled_files
= 0; do_handled_files
< 2; do_handled_files
++)
5354 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
5356 buf
= XCDR (XCAR (tail
));
5359 /* Record all the buffers that have auto save mode
5360 in the special file that lists them. For each of these buffers,
5361 Record visited name (if any) and auto save name. */
5362 if (STRINGP (b
->auto_save_file_name
)
5363 && stream
!= NULL
&& do_handled_files
== 0)
5366 if (!NILP (b
->filename
))
5368 fwrite (SDATA (b
->filename
), 1,
5369 SBYTES (b
->filename
), stream
);
5371 putc ('\n', stream
);
5372 fwrite (SDATA (b
->auto_save_file_name
), 1,
5373 SBYTES (b
->auto_save_file_name
), stream
);
5374 putc ('\n', stream
);
5378 if (!NILP (current_only
)
5379 && b
!= current_buffer
)
5382 /* Don't auto-save indirect buffers.
5383 The base buffer takes care of it. */
5387 /* Check for auto save enabled
5388 and file changed since last auto save
5389 and file changed since last real save. */
5390 if (STRINGP (b
->auto_save_file_name
)
5391 && BUF_SAVE_MODIFF (b
) < BUF_MODIFF (b
)
5392 && BUF_AUTOSAVE_MODIFF (b
) < BUF_MODIFF (b
)
5393 /* -1 means we've turned off autosaving for a while--see below. */
5394 && XINT (b
->save_length
) >= 0
5395 && (do_handled_files
5396 || NILP (Ffind_file_name_handler (b
->auto_save_file_name
,
5399 EMACS_TIME before_time
, after_time
;
5401 EMACS_GET_TIME (before_time
);
5403 /* If we had a failure, don't try again for 20 minutes. */
5404 if (b
->auto_save_failure_time
>= 0
5405 && EMACS_SECS (before_time
) - b
->auto_save_failure_time
< 1200)
5408 set_buffer_internal (b
);
5409 if (NILP (Vauto_save_include_big_deletions
)
5410 && (XFASTINT (b
->save_length
) * 10
5411 > (BUF_Z (b
) - BUF_BEG (b
)) * 13)
5412 /* A short file is likely to change a large fraction;
5413 spare the user annoying messages. */
5414 && XFASTINT (b
->save_length
) > 5000
5415 /* These messages are frequent and annoying for `*mail*'. */
5416 && !EQ (b
->filename
, Qnil
)
5417 && NILP (no_message
))
5419 /* It has shrunk too much; turn off auto-saving here. */
5420 minibuffer_auto_raise
= orig_minibuffer_auto_raise
;
5421 message_with_string ("Buffer %s has shrunk a lot; auto save disabled in that buffer until next real save",
5423 minibuffer_auto_raise
= 0;
5424 /* Turn off auto-saving until there's a real save,
5425 and prevent any more warnings. */
5426 XSETINT (b
->save_length
, -1);
5427 Fsleep_for (make_number (1), Qnil
);
5430 if (!auto_saved
&& NILP (no_message
))
5431 message1 ("Auto-saving...");
5432 internal_condition_case (auto_save_1
, Qt
, auto_save_error
);
5434 BUF_AUTOSAVE_MODIFF (b
) = BUF_MODIFF (b
);
5435 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
5436 set_buffer_internal (old
);
5438 EMACS_GET_TIME (after_time
);
5440 /* If auto-save took more than 60 seconds,
5441 assume it was an NFS failure that got a timeout. */
5442 if (EMACS_SECS (after_time
) - EMACS_SECS (before_time
) > 60)
5443 b
->auto_save_failure_time
= EMACS_SECS (after_time
);
5447 /* Prevent another auto save till enough input events come in. */
5448 record_auto_save ();
5450 if (auto_saved
&& NILP (no_message
))
5454 /* If we are going to restore an old message,
5455 give time to read ours. */
5456 sit_for (make_number (1), 0, 0);
5459 else if (!auto_save_error_occurred
)
5460 /* Don't overwrite the error message if an error occurred.
5461 If we displayed a message and then restored a state
5462 with no message, leave a "done" message on the screen. */
5463 message1 ("Auto-saving...done");
5468 /* This restores the message-stack status. */
5469 unbind_to (count
, Qnil
);
5473 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved
,
5474 Sset_buffer_auto_saved
, 0, 0, 0,
5475 doc
: /* Mark current buffer as auto-saved with its current text.
5476 No auto-save file will be written until the buffer changes again. */)
5479 /* FIXME: This should not be called in indirect buffers, since
5480 they're not autosaved. */
5481 BUF_AUTOSAVE_MODIFF (current_buffer
) = MODIFF
;
5482 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
5483 current_buffer
->auto_save_failure_time
= -1;
5487 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure
,
5488 Sclear_buffer_auto_save_failure
, 0, 0, 0,
5489 doc
: /* Clear any record of a recent auto-save failure in the current buffer. */)
5492 current_buffer
->auto_save_failure_time
= -1;
5496 DEFUN ("recent-auto-save-p", Frecent_auto_save_p
, Srecent_auto_save_p
,
5498 doc
: /* Return t if current buffer has been auto-saved recently.
5499 More precisely, if it has been auto-saved since last read from or saved
5500 in the visited file. If the buffer has no visited file,
5501 then any auto-save counts as "recent". */)
5504 /* FIXME: maybe we should return nil for indirect buffers since
5505 they're never autosaved. */
5506 return (SAVE_MODIFF
< BUF_AUTOSAVE_MODIFF (current_buffer
) ? Qt
: Qnil
);
5509 /* Reading and completing file names */
5511 DEFUN ("next-read-file-uses-dialog-p", Fnext_read_file_uses_dialog_p
,
5512 Snext_read_file_uses_dialog_p
, 0, 0, 0,
5513 doc
: /* Return t if a call to `read-file-name' will use a dialog.
5514 The return value is only relevant for a call to `read-file-name' that happens
5515 before any other event (mouse or keypress) is handled. */)
5518 #if defined (USE_MOTIF) || defined (HAVE_NTGUI) || defined (USE_GTK)
5519 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
5529 Fread_file_name (Lisp_Object prompt
, Lisp_Object dir
, Lisp_Object default_filename
, Lisp_Object mustmatch
, Lisp_Object initial
, Lisp_Object predicate
)
5531 struct gcpro gcpro1
, gcpro2
;
5532 Lisp_Object args
[7];
5534 GCPRO1 (default_filename
);
5535 args
[0] = intern ("read-file-name");
5538 args
[3] = default_filename
;
5539 args
[4] = mustmatch
;
5541 args
[6] = predicate
;
5542 RETURN_UNGCPRO (Ffuncall (7, args
));
5547 syms_of_fileio (void)
5549 Qoperations
= intern_c_string ("operations");
5550 Qexpand_file_name
= intern_c_string ("expand-file-name");
5551 Qsubstitute_in_file_name
= intern_c_string ("substitute-in-file-name");
5552 Qdirectory_file_name
= intern_c_string ("directory-file-name");
5553 Qfile_name_directory
= intern_c_string ("file-name-directory");
5554 Qfile_name_nondirectory
= intern_c_string ("file-name-nondirectory");
5555 Qunhandled_file_name_directory
= intern_c_string ("unhandled-file-name-directory");
5556 Qfile_name_as_directory
= intern_c_string ("file-name-as-directory");
5557 Qcopy_file
= intern_c_string ("copy-file");
5558 Qmake_directory_internal
= intern_c_string ("make-directory-internal");
5559 Qmake_directory
= intern_c_string ("make-directory");
5560 Qdelete_directory_internal
= intern_c_string ("delete-directory-internal");
5561 Qdelete_file
= intern_c_string ("delete-file");
5562 Qrename_file
= intern_c_string ("rename-file");
5563 Qadd_name_to_file
= intern_c_string ("add-name-to-file");
5564 Qmake_symbolic_link
= intern_c_string ("make-symbolic-link");
5565 Qfile_exists_p
= intern_c_string ("file-exists-p");
5566 Qfile_executable_p
= intern_c_string ("file-executable-p");
5567 Qfile_readable_p
= intern_c_string ("file-readable-p");
5568 Qfile_writable_p
= intern_c_string ("file-writable-p");
5569 Qfile_symlink_p
= intern_c_string ("file-symlink-p");
5570 Qaccess_file
= intern_c_string ("access-file");
5571 Qfile_directory_p
= intern_c_string ("file-directory-p");
5572 Qfile_regular_p
= intern_c_string ("file-regular-p");
5573 Qfile_accessible_directory_p
= intern_c_string ("file-accessible-directory-p");
5574 Qfile_modes
= intern_c_string ("file-modes");
5575 Qset_file_modes
= intern_c_string ("set-file-modes");
5576 Qset_file_times
= intern_c_string ("set-file-times");
5577 Qfile_selinux_context
= intern_c_string("file-selinux-context");
5578 Qset_file_selinux_context
= intern_c_string("set-file-selinux-context");
5579 Qfile_newer_than_file_p
= intern_c_string ("file-newer-than-file-p");
5580 Qinsert_file_contents
= intern_c_string ("insert-file-contents");
5581 Qwrite_region
= intern_c_string ("write-region");
5582 Qverify_visited_file_modtime
= intern_c_string ("verify-visited-file-modtime");
5583 Qset_visited_file_modtime
= intern_c_string ("set-visited-file-modtime");
5584 Qauto_save_coding
= intern_c_string ("auto-save-coding");
5586 staticpro (&Qoperations
);
5587 staticpro (&Qexpand_file_name
);
5588 staticpro (&Qsubstitute_in_file_name
);
5589 staticpro (&Qdirectory_file_name
);
5590 staticpro (&Qfile_name_directory
);
5591 staticpro (&Qfile_name_nondirectory
);
5592 staticpro (&Qunhandled_file_name_directory
);
5593 staticpro (&Qfile_name_as_directory
);
5594 staticpro (&Qcopy_file
);
5595 staticpro (&Qmake_directory_internal
);
5596 staticpro (&Qmake_directory
);
5597 staticpro (&Qdelete_directory_internal
);
5598 staticpro (&Qdelete_file
);
5599 staticpro (&Qrename_file
);
5600 staticpro (&Qadd_name_to_file
);
5601 staticpro (&Qmake_symbolic_link
);
5602 staticpro (&Qfile_exists_p
);
5603 staticpro (&Qfile_executable_p
);
5604 staticpro (&Qfile_readable_p
);
5605 staticpro (&Qfile_writable_p
);
5606 staticpro (&Qaccess_file
);
5607 staticpro (&Qfile_symlink_p
);
5608 staticpro (&Qfile_directory_p
);
5609 staticpro (&Qfile_regular_p
);
5610 staticpro (&Qfile_accessible_directory_p
);
5611 staticpro (&Qfile_modes
);
5612 staticpro (&Qset_file_modes
);
5613 staticpro (&Qset_file_times
);
5614 staticpro (&Qfile_selinux_context
);
5615 staticpro (&Qset_file_selinux_context
);
5616 staticpro (&Qfile_newer_than_file_p
);
5617 staticpro (&Qinsert_file_contents
);
5618 staticpro (&Qwrite_region
);
5619 staticpro (&Qverify_visited_file_modtime
);
5620 staticpro (&Qset_visited_file_modtime
);
5621 staticpro (&Qauto_save_coding
);
5623 Qfile_name_history
= intern_c_string ("file-name-history");
5624 Fset (Qfile_name_history
, Qnil
);
5625 staticpro (&Qfile_name_history
);
5627 Qfile_error
= intern_c_string ("file-error");
5628 staticpro (&Qfile_error
);
5629 Qfile_already_exists
= intern_c_string ("file-already-exists");
5630 staticpro (&Qfile_already_exists
);
5631 Qfile_date_error
= intern_c_string ("file-date-error");
5632 staticpro (&Qfile_date_error
);
5633 Qexcl
= intern_c_string ("excl");
5637 Qfind_buffer_file_type
= intern_c_string ("find-buffer-file-type");
5638 staticpro (&Qfind_buffer_file_type
);
5641 DEFVAR_LISP ("file-name-coding-system", &Vfile_name_coding_system
,
5642 doc
: /* *Coding system for encoding file names.
5643 If it is nil, `default-file-name-coding-system' (which see) is used. */);
5644 Vfile_name_coding_system
= Qnil
;
5646 DEFVAR_LISP ("default-file-name-coding-system",
5647 &Vdefault_file_name_coding_system
,
5648 doc
: /* Default coding system for encoding file names.
5649 This variable is used only when `file-name-coding-system' is nil.
5651 This variable is set/changed by the command `set-language-environment'.
5652 User should not set this variable manually,
5653 instead use `file-name-coding-system' to get a constant encoding
5654 of file names regardless of the current language environment. */);
5655 Vdefault_file_name_coding_system
= Qnil
;
5657 Qformat_decode
= intern_c_string ("format-decode");
5658 staticpro (&Qformat_decode
);
5659 Qformat_annotate_function
= intern_c_string ("format-annotate-function");
5660 staticpro (&Qformat_annotate_function
);
5661 Qafter_insert_file_set_coding
= intern_c_string ("after-insert-file-set-coding");
5662 staticpro (&Qafter_insert_file_set_coding
);
5664 Qcar_less_than_car
= intern_c_string ("car-less-than-car");
5665 staticpro (&Qcar_less_than_car
);
5667 Fput (Qfile_error
, Qerror_conditions
,
5668 Fpurecopy (list2 (Qfile_error
, Qerror
)));
5669 Fput (Qfile_error
, Qerror_message
,
5670 make_pure_c_string ("File error"));
5672 Fput (Qfile_already_exists
, Qerror_conditions
,
5673 Fpurecopy (list3 (Qfile_already_exists
, Qfile_error
, Qerror
)));
5674 Fput (Qfile_already_exists
, Qerror_message
,
5675 make_pure_c_string ("File already exists"));
5677 Fput (Qfile_date_error
, Qerror_conditions
,
5678 Fpurecopy (list3 (Qfile_date_error
, Qfile_error
, Qerror
)));
5679 Fput (Qfile_date_error
, Qerror_message
,
5680 make_pure_c_string ("Cannot set file date"));
5682 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist
,
5683 doc
: /* *Alist of elements (REGEXP . HANDLER) for file names handled specially.
5684 If a file name matches REGEXP, then all I/O on that file is done by calling
5687 The first argument given to HANDLER is the name of the I/O primitive
5688 to be handled; the remaining arguments are the arguments that were
5689 passed to that primitive. For example, if you do
5690 (file-exists-p FILENAME)
5691 and FILENAME is handled by HANDLER, then HANDLER is called like this:
5692 (funcall HANDLER 'file-exists-p FILENAME)
5693 The function `find-file-name-handler' checks this list for a handler
5694 for its argument. */);
5695 Vfile_name_handler_alist
= Qnil
;
5697 DEFVAR_LISP ("set-auto-coding-function",
5698 &Vset_auto_coding_function
,
5699 doc
: /* If non-nil, a function to call to decide a coding system of file.
5700 Two arguments are passed to this function: the file name
5701 and the length of a file contents following the point.
5702 This function should return a coding system to decode the file contents.
5703 It should check the file name against `auto-coding-alist'.
5704 If no coding system is decided, it should check a coding system
5705 specified in the heading lines with the format:
5706 -*- ... coding: CODING-SYSTEM; ... -*-
5707 or local variable spec of the tailing lines with `coding:' tag. */);
5708 Vset_auto_coding_function
= Qnil
;
5710 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions
,
5711 doc
: /* A list of functions to be called at the end of `insert-file-contents'.
5712 Each is passed one argument, the number of characters inserted,
5713 with point at the start of the inserted text. Each function
5714 should leave point the same, and return the new character count.
5715 If `insert-file-contents' is intercepted by a handler from
5716 `file-name-handler-alist', that handler is responsible for calling the
5717 functions in `after-insert-file-functions' if appropriate. */);
5718 Vafter_insert_file_functions
= Qnil
;
5720 DEFVAR_LISP ("write-region-annotate-functions", &Vwrite_region_annotate_functions
,
5721 doc
: /* A list of functions to be called at the start of `write-region'.
5722 Each is passed two arguments, START and END as for `write-region'.
5723 These are usually two numbers but not always; see the documentation
5724 for `write-region'. The function should return a list of pairs
5725 of the form (POSITION . STRING), consisting of strings to be effectively
5726 inserted at the specified positions of the file being written (1 means to
5727 insert before the first byte written). The POSITIONs must be sorted into
5730 If there are several annotation functions, the lists returned by these
5731 functions are merged destructively. As each annotation function runs,
5732 the variable `write-region-annotations-so-far' contains a list of all
5733 annotations returned by previous annotation functions.
5735 An annotation function can return with a different buffer current.
5736 Doing so removes the annotations returned by previous functions, and
5737 resets START and END to `point-min' and `point-max' of the new buffer.
5739 After `write-region' completes, Emacs calls the function stored in
5740 `write-region-post-annotation-function', once for each buffer that was
5741 current when building the annotations (i.e., at least once), with that
5742 buffer current. */);
5743 Vwrite_region_annotate_functions
= Qnil
;
5744 staticpro (&Qwrite_region_annotate_functions
);
5745 Qwrite_region_annotate_functions
5746 = intern_c_string ("write-region-annotate-functions");
5748 DEFVAR_LISP ("write-region-post-annotation-function",
5749 &Vwrite_region_post_annotation_function
,
5750 doc
: /* Function to call after `write-region' completes.
5751 The function is called with no arguments. If one or more of the
5752 annotation functions in `write-region-annotate-functions' changed the
5753 current buffer, the function stored in this variable is called for
5754 each of those additional buffers as well, in addition to the original
5755 buffer. The relevant buffer is current during each function call. */);
5756 Vwrite_region_post_annotation_function
= Qnil
;
5757 staticpro (&Vwrite_region_annotation_buffers
);
5759 DEFVAR_LISP ("write-region-annotations-so-far",
5760 &Vwrite_region_annotations_so_far
,
5761 doc
: /* When an annotation function is called, this holds the previous annotations.
5762 These are the annotations made by other annotation functions
5763 that were already called. See also `write-region-annotate-functions'. */);
5764 Vwrite_region_annotations_so_far
= Qnil
;
5766 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers
,
5767 doc
: /* A list of file name handlers that temporarily should not be used.
5768 This applies only to the operation `inhibit-file-name-operation'. */);
5769 Vinhibit_file_name_handlers
= Qnil
;
5771 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation
,
5772 doc
: /* The operation for which `inhibit-file-name-handlers' is applicable. */);
5773 Vinhibit_file_name_operation
= Qnil
;
5775 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name
,
5776 doc
: /* File name in which we write a list of all auto save file names.
5777 This variable is initialized automatically from `auto-save-list-file-prefix'
5778 shortly after Emacs reads your `.emacs' file, if you have not yet given it
5779 a non-nil value. */);
5780 Vauto_save_list_file_name
= Qnil
;
5782 DEFVAR_LISP ("auto-save-visited-file-name", &Vauto_save_visited_file_name
,
5783 doc
: /* Non-nil says auto-save a buffer in the file it is visiting, when practical.
5784 Normally auto-save files are written under other names. */);
5785 Vauto_save_visited_file_name
= Qnil
;
5787 DEFVAR_LISP ("auto-save-include-big-deletions", &Vauto_save_include_big_deletions
,
5788 doc
: /* If non-nil, auto-save even if a large part of the text is deleted.
5789 If nil, deleting a substantial portion of the text disables auto-save
5790 in the buffer; this is the default behavior, because the auto-save
5791 file is usually more useful if it contains the deleted text. */);
5792 Vauto_save_include_big_deletions
= Qnil
;
5795 DEFVAR_BOOL ("write-region-inhibit-fsync", &write_region_inhibit_fsync
,
5796 doc
: /* *Non-nil means don't call fsync in `write-region'.
5797 This variable affects calls to `write-region' as well as save commands.
5798 A non-nil value may result in data loss! */);
5799 write_region_inhibit_fsync
= 0;
5802 DEFVAR_BOOL ("delete-by-moving-to-trash", &delete_by_moving_to_trash
,
5803 doc
: /* Specifies whether to use the system's trash can.
5804 When non-nil, certain file deletion commands use the function
5805 `move-file-to-trash' instead of deleting files outright.
5806 This includes interactive calls to `delete-file' and
5807 `delete-directory' and the Dired deletion commands. */);
5808 delete_by_moving_to_trash
= 0;
5809 Qdelete_by_moving_to_trash
= intern_c_string ("delete-by-moving-to-trash");
5810 Qmove_file_to_trash
= intern_c_string ("move-file-to-trash");
5811 staticpro (&Qmove_file_to_trash
);
5812 Qcopy_directory
= intern_c_string ("copy-directory");
5813 staticpro (&Qcopy_directory
);
5814 Qdelete_directory
= intern_c_string ("delete-directory");
5815 staticpro (&Qdelete_directory
);
5817 defsubr (&Sfind_file_name_handler
);
5818 defsubr (&Sfile_name_directory
);
5819 defsubr (&Sfile_name_nondirectory
);
5820 defsubr (&Sunhandled_file_name_directory
);
5821 defsubr (&Sfile_name_as_directory
);
5822 defsubr (&Sdirectory_file_name
);
5823 defsubr (&Smake_temp_name
);
5824 defsubr (&Sexpand_file_name
);
5825 defsubr (&Ssubstitute_in_file_name
);
5826 defsubr (&Scopy_file
);
5827 defsubr (&Smake_directory_internal
);
5828 defsubr (&Sdelete_directory_internal
);
5829 defsubr (&Sdelete_file
);
5830 defsubr (&Srename_file
);
5831 defsubr (&Sadd_name_to_file
);
5832 defsubr (&Smake_symbolic_link
);
5833 defsubr (&Sfile_name_absolute_p
);
5834 defsubr (&Sfile_exists_p
);
5835 defsubr (&Sfile_executable_p
);
5836 defsubr (&Sfile_readable_p
);
5837 defsubr (&Sfile_writable_p
);
5838 defsubr (&Saccess_file
);
5839 defsubr (&Sfile_symlink_p
);
5840 defsubr (&Sfile_directory_p
);
5841 defsubr (&Sfile_accessible_directory_p
);
5842 defsubr (&Sfile_regular_p
);
5843 defsubr (&Sfile_modes
);
5844 defsubr (&Sset_file_modes
);
5845 defsubr (&Sset_file_times
);
5846 defsubr (&Sfile_selinux_context
);
5847 defsubr (&Sset_file_selinux_context
);
5848 defsubr (&Sset_default_file_modes
);
5849 defsubr (&Sdefault_file_modes
);
5850 defsubr (&Sfile_newer_than_file_p
);
5851 defsubr (&Sinsert_file_contents
);
5852 defsubr (&Swrite_region
);
5853 defsubr (&Scar_less_than_car
);
5854 defsubr (&Sverify_visited_file_modtime
);
5855 defsubr (&Sclear_visited_file_modtime
);
5856 defsubr (&Svisited_file_modtime
);
5857 defsubr (&Sset_visited_file_modtime
);
5858 defsubr (&Sdo_auto_save
);
5859 defsubr (&Sset_buffer_auto_saved
);
5860 defsubr (&Sclear_buffer_auto_save_failure
);
5861 defsubr (&Srecent_auto_save_p
);
5863 defsubr (&Snext_read_file_uses_dialog_p
);
5866 defsubr (&Sunix_sync
);