1 /* File IO for GNU Emacs.
2 Copyright (C) 1985,86,87,88,93,94,95,96,97,98,99,2000, 2001
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
22 #define _GNU_SOURCE /* for euidaccess */
26 #if defined (USG5) || defined (BSD_SYSTEM) || defined (LINUX)
31 #include <sys/types.h>
38 #if !defined (S_ISLNK) && defined (S_IFLNK)
39 # define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK)
42 #if !defined (S_ISFIFO) && defined (S_IFIFO)
43 # define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO)
46 #if !defined (S_ISREG) && defined (S_IFREG)
47 # define S_ISREG(m) (((m) & S_IFMT) == S_IFREG)
88 #include "intervals.h"
99 #endif /* not WINDOWSNT */
103 #include <sys/param.h>
111 #define CORRECT_DIR_SEPS(s) \
112 do { if ('/' == DIRECTORY_SEP) dostounix_filename (s); \
113 else unixtodos_filename (s); \
115 /* On Windows, drive letters must be alphabetic - on DOS, the Netware
116 redirector allows the six letters between 'Z' and 'a' as well. */
118 #define IS_DRIVE(x) ((x) >= 'A' && (x) <= 'z')
121 #define IS_DRIVE(x) isalpha (x)
123 /* Need to lower-case the drive letter, or else expanded
124 filenames will sometimes compare inequal, because
125 `expand-file-name' doesn't always down-case the drive letter. */
126 #define DRIVE_LETTER(x) (tolower (x))
147 #include "commands.h"
148 extern int use_dialog_box
;
162 /* Nonzero during writing of auto-save files */
165 /* Set by auto_save_1 to mode of original file so Fwrite_region will create
166 a new file with the same mode as the original */
167 int auto_save_mode_bits
;
169 /* Coding system for file names, or nil if none. */
170 Lisp_Object Vfile_name_coding_system
;
172 /* Coding system for file names used only when
173 Vfile_name_coding_system is nil. */
174 Lisp_Object Vdefault_file_name_coding_system
;
176 /* Alist of elements (REGEXP . HANDLER) for file names
177 whose I/O is done with a special handler. */
178 Lisp_Object Vfile_name_handler_alist
;
180 /* Format for auto-save files */
181 Lisp_Object Vauto_save_file_format
;
183 /* Lisp functions for translating file formats */
184 Lisp_Object Qformat_decode
, Qformat_annotate_function
;
186 /* Function to be called to decide a coding system of a reading file. */
187 Lisp_Object Vset_auto_coding_function
;
189 /* Functions to be called to process text properties in inserted file. */
190 Lisp_Object Vafter_insert_file_functions
;
192 /* Functions to be called to create text property annotations for file. */
193 Lisp_Object Vwrite_region_annotate_functions
;
195 /* During build_annotations, each time an annotation function is called,
196 this holds the annotations made by the previous functions. */
197 Lisp_Object Vwrite_region_annotations_so_far
;
199 /* File name in which we write a list of all our auto save files. */
200 Lisp_Object Vauto_save_list_file_name
;
202 /* Nonzero means, when reading a filename in the minibuffer,
203 start out by inserting the default directory into the minibuffer. */
204 int insert_default_directory
;
206 /* On VMS, nonzero means write new files with record format stmlf.
207 Zero means use var format. */
210 /* On NT, specifies the directory separator character, used (eg.) when
211 expanding file names. This can be bound to / or \. */
212 Lisp_Object Vdirectory_sep_char
;
214 extern Lisp_Object Vuser_login_name
;
217 extern Lisp_Object Vw32_get_true_file_attributes
;
220 extern int minibuf_level
;
222 extern int minibuffer_auto_raise
;
224 /* These variables describe handlers that have "already" had a chance
225 to handle the current operation.
227 Vinhibit_file_name_handlers is a list of file name handlers.
228 Vinhibit_file_name_operation is the operation being handled.
229 If we try to handle that operation, we ignore those handlers. */
231 static Lisp_Object Vinhibit_file_name_handlers
;
232 static Lisp_Object Vinhibit_file_name_operation
;
234 Lisp_Object Qfile_error
, Qfile_already_exists
, Qfile_date_error
;
236 Lisp_Object Qfile_name_history
;
238 Lisp_Object Qcar_less_than_car
;
240 static int a_write
P_ ((int, Lisp_Object
, int, int,
241 Lisp_Object
*, struct coding_system
*));
242 static int e_write
P_ ((int, Lisp_Object
, int, int, struct coding_system
*));
246 report_file_error (string
, data
)
250 Lisp_Object errstring
;
253 synchronize_system_messages_locale ();
254 errstring
= code_convert_string_norecord (build_string (strerror (errorno
)),
255 Vlocale_coding_system
, 0);
261 Fsignal (Qfile_already_exists
, Fcons (errstring
, data
));
264 /* System error messages are capitalized. Downcase the initial
265 unless it is followed by a slash. */
266 if (XSTRING (errstring
)->data
[1] != '/')
267 XSTRING (errstring
)->data
[0] = DOWNCASE (XSTRING (errstring
)->data
[0]);
269 Fsignal (Qfile_error
,
270 Fcons (build_string (string
), Fcons (errstring
, data
)));
275 close_file_unwind (fd
)
278 emacs_close (XFASTINT (fd
));
282 /* Restore point, having saved it as a marker. */
285 restore_point_unwind (location
)
286 Lisp_Object location
;
288 Fgoto_char (location
);
289 Fset_marker (location
, Qnil
, Qnil
);
293 Lisp_Object Qexpand_file_name
;
294 Lisp_Object Qsubstitute_in_file_name
;
295 Lisp_Object Qdirectory_file_name
;
296 Lisp_Object Qfile_name_directory
;
297 Lisp_Object Qfile_name_nondirectory
;
298 Lisp_Object Qunhandled_file_name_directory
;
299 Lisp_Object Qfile_name_as_directory
;
300 Lisp_Object Qcopy_file
;
301 Lisp_Object Qmake_directory_internal
;
302 Lisp_Object Qmake_directory
;
303 Lisp_Object Qdelete_directory
;
304 Lisp_Object Qdelete_file
;
305 Lisp_Object Qrename_file
;
306 Lisp_Object Qadd_name_to_file
;
307 Lisp_Object Qmake_symbolic_link
;
308 Lisp_Object Qfile_exists_p
;
309 Lisp_Object Qfile_executable_p
;
310 Lisp_Object Qfile_readable_p
;
311 Lisp_Object Qfile_writable_p
;
312 Lisp_Object Qfile_symlink_p
;
313 Lisp_Object Qaccess_file
;
314 Lisp_Object Qfile_directory_p
;
315 Lisp_Object Qfile_regular_p
;
316 Lisp_Object Qfile_accessible_directory_p
;
317 Lisp_Object Qfile_modes
;
318 Lisp_Object Qset_file_modes
;
319 Lisp_Object Qfile_newer_than_file_p
;
320 Lisp_Object Qinsert_file_contents
;
321 Lisp_Object Qwrite_region
;
322 Lisp_Object Qverify_visited_file_modtime
;
323 Lisp_Object Qset_visited_file_modtime
;
325 DEFUN ("find-file-name-handler", Ffind_file_name_handler
, Sfind_file_name_handler
, 2, 2, 0,
326 doc
: /* Return FILENAME's handler function for OPERATION, if it has one.
327 Otherwise, return nil.
328 A file name is handled if one of the regular expressions in
329 `file-name-handler-alist' matches it.
331 If OPERATION equals `inhibit-file-name-operation', then we ignore
332 any handlers that are members of `inhibit-file-name-handlers',
333 but we still do run any other handlers. This lets handlers
334 use the standard functions without calling themselves recursively. */)
335 (filename
, operation
)
336 Lisp_Object filename
, operation
;
338 /* This function must not munge the match data. */
339 Lisp_Object chain
, inhibited_handlers
;
341 CHECK_STRING (filename
);
343 if (EQ (operation
, Vinhibit_file_name_operation
))
344 inhibited_handlers
= Vinhibit_file_name_handlers
;
346 inhibited_handlers
= Qnil
;
348 for (chain
= Vfile_name_handler_alist
; CONSP (chain
);
349 chain
= XCDR (chain
))
357 if (STRINGP (string
) && fast_string_match (string
, filename
) >= 0)
359 Lisp_Object handler
, tem
;
361 handler
= XCDR (elt
);
362 tem
= Fmemq (handler
, inhibited_handlers
);
373 DEFUN ("file-name-directory", Ffile_name_directory
, Sfile_name_directory
,
375 doc
: /* Return the directory component in file name FILENAME.
376 Return nil if FILENAME does not include a directory.
377 Otherwise return a directory spec.
378 Given a Unix syntax file name, returns a string ending in slash;
379 on VMS, perhaps instead a string ending in `:', `]' or `>'. */)
381 Lisp_Object filename
;
383 register unsigned char *beg
;
384 register 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 #ifdef FILE_SYSTEM_CASE
396 filename
= FILE_SYSTEM_CASE (filename
);
398 beg
= XSTRING (filename
)->data
;
400 beg
= strcpy (alloca (strlen (beg
) + 1), beg
);
402 p
= beg
+ STRING_BYTES (XSTRING (filename
));
404 while (p
!= beg
&& !IS_DIRECTORY_SEP (p
[-1])
406 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
409 /* only recognise drive specifier at the beginning */
411 /* handle the "/:d:foo" and "/:foo" cases correctly */
412 && ((p
== beg
+ 2 && !IS_DIRECTORY_SEP (*beg
))
413 || (p
== beg
+ 4 && IS_DIRECTORY_SEP (*beg
))))
420 /* Expansion of "c:" to drive and default directory. */
423 /* MAXPATHLEN+1 is guaranteed to be enough space for getdefdir. */
424 unsigned char *res
= alloca (MAXPATHLEN
+ 1);
425 unsigned char *r
= res
;
427 if (p
== beg
+ 4 && IS_DIRECTORY_SEP (*beg
) && beg
[1] == ':')
429 strncpy (res
, beg
, 2);
434 if (getdefdir (toupper (*beg
) - 'A' + 1, r
))
436 if (!IS_DIRECTORY_SEP (res
[strlen (res
) - 1]))
439 p
= beg
+ strlen (beg
);
442 CORRECT_DIR_SEPS (beg
);
445 if (STRING_MULTIBYTE (filename
))
446 return make_string (beg
, p
- beg
);
447 return make_unibyte_string (beg
, p
- beg
);
450 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory
,
451 Sfile_name_nondirectory
, 1, 1, 0,
452 doc
: /* Return file name FILENAME sans its directory.
453 For example, in a Unix-syntax file name,
454 this is everything after the last slash,
455 or the entire name if it contains no slash. */)
457 Lisp_Object filename
;
459 register unsigned char *beg
, *p
, *end
;
462 CHECK_STRING (filename
);
464 /* If the file name has special constructs in it,
465 call the corresponding file handler. */
466 handler
= Ffind_file_name_handler (filename
, Qfile_name_nondirectory
);
468 return call2 (handler
, Qfile_name_nondirectory
, filename
);
470 beg
= XSTRING (filename
)->data
;
471 end
= p
= beg
+ STRING_BYTES (XSTRING (filename
));
473 while (p
!= beg
&& !IS_DIRECTORY_SEP (p
[-1])
475 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
478 /* only recognise drive specifier at beginning */
480 /* handle the "/:d:foo" case correctly */
481 && (p
== beg
+ 2 || (p
== beg
+ 4 && IS_DIRECTORY_SEP (*beg
))))
486 if (STRING_MULTIBYTE (filename
))
487 return make_string (p
, end
- p
);
488 return make_unibyte_string (p
, end
- p
);
491 DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory
,
492 Sunhandled_file_name_directory
, 1, 1, 0,
493 doc
: /* Return a directly usable directory name somehow associated with FILENAME.
494 A `directly usable' directory name is one that may be used without the
495 intervention of any file handler.
496 If FILENAME is a directly usable file itself, return
497 \(file-name-directory FILENAME).
498 The `call-process' and `start-process' functions use this function to
499 get a current directory to run processes in. */)
501 Lisp_Object filename
;
505 /* If the file name has special constructs in it,
506 call the corresponding file handler. */
507 handler
= Ffind_file_name_handler (filename
, Qunhandled_file_name_directory
);
509 return call2 (handler
, Qunhandled_file_name_directory
, filename
);
511 return Ffile_name_directory (filename
);
516 file_name_as_directory (out
, in
)
519 int size
= strlen (in
) - 1;
532 /* Is it already a directory string? */
533 if (in
[size
] == ':' || in
[size
] == ']' || in
[size
] == '>')
535 /* Is it a VMS directory file name? If so, hack VMS syntax. */
536 else if (! index (in
, '/')
537 && ((size
> 3 && ! strcmp (&in
[size
- 3], ".DIR"))
538 || (size
> 3 && ! strcmp (&in
[size
- 3], ".dir"))
539 || (size
> 5 && (! strncmp (&in
[size
- 5], ".DIR", 4)
540 || ! strncmp (&in
[size
- 5], ".dir", 4))
541 && (in
[size
- 1] == '.' || in
[size
- 1] == ';')
542 && in
[size
] == '1')))
544 register char *p
, *dot
;
548 dir:x.dir --> dir:[x]
549 dir:[x]y.dir --> dir:[x.y] */
551 while (p
!= in
&& *p
!= ':' && *p
!= '>' && *p
!= ']') p
--;
554 strncpy (out
, in
, p
- in
);
573 dot
= index (p
, '.');
576 /* blindly remove any extension */
577 size
= strlen (out
) + (dot
- p
);
578 strncat (out
, p
, dot
- p
);
589 /* For Unix syntax, Append a slash if necessary */
590 if (!IS_DIRECTORY_SEP (out
[size
]))
592 out
[size
+ 1] = DIRECTORY_SEP
;
593 out
[size
+ 2] = '\0';
596 CORRECT_DIR_SEPS (out
);
602 DEFUN ("file-name-as-directory", Ffile_name_as_directory
,
603 Sfile_name_as_directory
, 1, 1, 0,
604 doc
: /* Return a string representing file FILENAME interpreted as a directory.
605 This operation exists because a directory is also a file, but its name as
606 a directory is different from its name as a file.
607 The result can be used as the value of `default-directory'
608 or passed as second argument to `expand-file-name'.
609 For a Unix-syntax file name, just appends a slash.
610 On VMS, converts \"[X]FOO.DIR\" to \"[X.FOO]\", etc. */)
621 /* If the file name has special constructs in it,
622 call the corresponding file handler. */
623 handler
= Ffind_file_name_handler (file
, Qfile_name_as_directory
);
625 return call2 (handler
, Qfile_name_as_directory
, file
);
627 buf
= (char *) alloca (STRING_BYTES (XSTRING (file
)) + 10);
628 return build_string (file_name_as_directory (buf
, XSTRING (file
)->data
));
632 * Convert from directory name to filename.
634 * xyzzy:[mukesh.emacs] => xyzzy:[mukesh]emacs.dir.1
635 * xyzzy:[mukesh] => xyzzy:[000000]mukesh.dir.1
636 * On UNIX, it's simple: just make sure there isn't a terminating /
638 * Value is nonzero if the string output is different from the input.
642 directory_file_name (src
, dst
)
650 struct FAB fab
= cc$rms_fab
;
651 struct NAM nam
= cc$rms_nam
;
652 char esa
[NAM$C_MAXRSS
];
657 if (! index (src
, '/')
658 && (src
[slen
- 1] == ']'
659 || src
[slen
- 1] == ':'
660 || src
[slen
- 1] == '>'))
662 /* VMS style - convert [x.y.z] to [x.y]z, [x] to [000000]x */
664 fab
.fab$b_fns
= slen
;
665 fab
.fab$l_nam
= &nam
;
666 fab
.fab$l_fop
= FAB$M_NAM
;
669 nam
.nam$b_ess
= sizeof esa
;
670 nam
.nam$b_nop
|= NAM$M_SYNCHK
;
672 /* We call SYS$PARSE to handle such things as [--] for us. */
673 if (SYS$
PARSE (&fab
, 0, 0) == RMS$_NORMAL
)
675 slen
= nam
.nam$b_esl
;
676 if (esa
[slen
- 1] == ';' && esa
[slen
- 2] == '.')
681 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
683 /* what about when we have logical_name:???? */
684 if (src
[slen
- 1] == ':')
685 { /* Xlate logical name and see what we get */
686 ptr
= strcpy (dst
, src
); /* upper case for getenv */
689 if ('a' <= *ptr
&& *ptr
<= 'z')
693 dst
[slen
- 1] = 0; /* remove colon */
694 if (!(src
= egetenv (dst
)))
696 /* should we jump to the beginning of this procedure?
697 Good points: allows us to use logical names that xlate
699 Bad points: can be a problem if we just translated to a device
701 For now, I'll punt and always expect VMS names, and hope for
704 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
705 { /* no recursion here! */
711 { /* not a directory spec */
716 bracket
= src
[slen
- 1];
718 /* If bracket is ']' or '>', bracket - 2 is the corresponding
720 ptr
= index (src
, bracket
- 2);
722 { /* no opening bracket */
726 if (!(rptr
= rindex (src
, '.')))
729 strncpy (dst
, src
, slen
);
733 dst
[slen
++] = bracket
;
738 /* If we have the top-level of a rooted directory (i.e. xx:[000000]),
739 then translate the device and recurse. */
740 if (dst
[slen
- 1] == ':'
741 && dst
[slen
- 2] != ':' /* skip decnet nodes */
742 && strcmp (src
+ slen
, "[000000]") == 0)
744 dst
[slen
- 1] = '\0';
745 if ((ptr
= egetenv (dst
))
746 && (rlen
= strlen (ptr
) - 1) > 0
747 && (ptr
[rlen
] == ']' || ptr
[rlen
] == '>')
748 && ptr
[rlen
- 1] == '.')
750 char * buf
= (char *) alloca (strlen (ptr
) + 1);
754 return directory_file_name (buf
, dst
);
759 strcat (dst
, "[000000]");
763 rlen
= strlen (rptr
) - 1;
764 strncat (dst
, rptr
, rlen
);
765 dst
[slen
+ rlen
] = '\0';
766 strcat (dst
, ".DIR.1");
770 /* Process as Unix format: just remove any final slash.
771 But leave "/" unchanged; do not change it to "". */
774 /* Handle // as root for apollo's. */
775 if ((slen
> 2 && dst
[slen
- 1] == '/')
776 || (slen
> 1 && dst
[0] != '/' && dst
[slen
- 1] == '/'))
780 && IS_DIRECTORY_SEP (dst
[slen
- 1])
782 && !IS_ANY_SEP (dst
[slen
- 2])
788 CORRECT_DIR_SEPS (dst
);
793 DEFUN ("directory-file-name", Fdirectory_file_name
, Sdirectory_file_name
,
795 doc
: /* Returns the file name of the directory named DIRECTORY.
796 This is the name of the file that holds the data for the directory DIRECTORY.
797 This operation exists because a directory is also a file, but its name as
798 a directory is different from its name as a file.
799 In Unix-syntax, this function just removes the final slash.
800 On VMS, given a VMS-syntax directory name such as \"[X.Y]\",
801 it returns a file name such as \"[X]Y.DIR.1\". */)
803 Lisp_Object directory
;
808 CHECK_STRING (directory
);
810 if (NILP (directory
))
813 /* If the file name has special constructs in it,
814 call the corresponding file handler. */
815 handler
= Ffind_file_name_handler (directory
, Qdirectory_file_name
);
817 return call2 (handler
, Qdirectory_file_name
, directory
);
820 /* 20 extra chars is insufficient for VMS, since we might perform a
821 logical name translation. an equivalence string can be up to 255
822 chars long, so grab that much extra space... - sss */
823 buf
= (char *) alloca (STRING_BYTES (XSTRING (directory
)) + 20 + 255);
825 buf
= (char *) alloca (STRING_BYTES (XSTRING (directory
)) + 20);
827 directory_file_name (XSTRING (directory
)->data
, buf
);
828 return build_string (buf
);
831 static char make_temp_name_tbl
[64] =
833 'A','B','C','D','E','F','G','H',
834 'I','J','K','L','M','N','O','P',
835 'Q','R','S','T','U','V','W','X',
836 'Y','Z','a','b','c','d','e','f',
837 'g','h','i','j','k','l','m','n',
838 'o','p','q','r','s','t','u','v',
839 'w','x','y','z','0','1','2','3',
840 '4','5','6','7','8','9','-','_'
843 static unsigned make_temp_name_count
, make_temp_name_count_initialized_p
;
845 /* Value is a temporary file name starting with PREFIX, a string.
847 The Emacs process number forms part of the result, so there is
848 no danger of generating a name being used by another process.
849 In addition, this function makes an attempt to choose a name
850 which has no existing file. To make this work, PREFIX should be
851 an absolute file name.
853 BASE64_P non-zero means add the pid as 3 characters in base64
854 encoding. In this case, 6 characters will be added to PREFIX to
855 form the file name. Otherwise, if Emacs is running on a system
856 with long file names, add the pid as a decimal number.
858 This function signals an error if no unique file name could be
862 make_temp_name (prefix
, base64_p
)
869 unsigned char *p
, *data
;
873 CHECK_STRING (prefix
);
875 /* VAL is created by adding 6 characters to PREFIX. The first
876 three are the PID of this process, in base 64, and the second
877 three are incremented if the file already exists. This ensures
878 262144 unique file names per PID per PREFIX. */
880 pid
= (int) getpid ();
884 pidbuf
[0] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
885 pidbuf
[1] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
886 pidbuf
[2] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
891 #ifdef HAVE_LONG_FILE_NAMES
892 sprintf (pidbuf
, "%d", pid
);
893 pidlen
= strlen (pidbuf
);
895 pidbuf
[0] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
896 pidbuf
[1] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
897 pidbuf
[2] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
902 len
= XSTRING (prefix
)->size
;
903 val
= make_uninit_string (len
+ 3 + pidlen
);
904 data
= XSTRING (val
)->data
;
905 bcopy(XSTRING (prefix
)->data
, data
, len
);
908 bcopy (pidbuf
, p
, pidlen
);
911 /* Here we try to minimize useless stat'ing when this function is
912 invoked many times successively with the same PREFIX. We achieve
913 this by initializing count to a random value, and incrementing it
916 We don't want make-temp-name to be called while dumping,
917 because then make_temp_name_count_initialized_p would get set
918 and then make_temp_name_count would not be set when Emacs starts. */
920 if (!make_temp_name_count_initialized_p
)
922 make_temp_name_count
= (unsigned) time (NULL
);
923 make_temp_name_count_initialized_p
= 1;
929 unsigned num
= make_temp_name_count
;
931 p
[0] = make_temp_name_tbl
[num
& 63], num
>>= 6;
932 p
[1] = make_temp_name_tbl
[num
& 63], num
>>= 6;
933 p
[2] = make_temp_name_tbl
[num
& 63], num
>>= 6;
935 /* Poor man's congruential RN generator. Replace with
936 ++make_temp_name_count for debugging. */
937 make_temp_name_count
+= 25229;
938 make_temp_name_count
%= 225307;
940 if (stat (data
, &ignored
) < 0)
942 /* We want to return only if errno is ENOENT. */
946 /* The error here is dubious, but there is little else we
947 can do. The alternatives are to return nil, which is
948 as bad as (and in many cases worse than) throwing the
949 error, or to ignore the error, which will likely result
950 in looping through 225307 stat's, which is not only
951 dog-slow, but also useless since it will fallback to
952 the errow below, anyway. */
953 report_file_error ("Cannot create temporary name for prefix",
954 Fcons (prefix
, Qnil
));
959 error ("Cannot create temporary name for prefix `%s'",
960 XSTRING (prefix
)->data
);
965 DEFUN ("make-temp-name", Fmake_temp_name
, Smake_temp_name
, 1, 1, 0,
966 doc
: /* Generate temporary file name (string) starting with PREFIX (a string).
967 The Emacs process number forms part of the result,
968 so there is no danger of generating a name being used by another process.
970 In addition, this function makes an attempt to choose a name
971 which has no existing file. To make this work,
972 PREFIX should be an absolute file name.
974 There is a race condition between calling `make-temp-name' and creating the
975 file which opens all kinds of security holes. For that reason, you should
976 probably use `make-temp-file' instead. */)
980 return make_temp_name (prefix
, 0);
985 DEFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
986 doc
: /* Convert filename NAME to absolute, and canonicalize it.
987 Second arg DEFAULT-DIRECTORY is directory to start with if NAME is relative
988 (does not start with slash); if DEFAULT-DIRECTORY is nil or missing,
989 the current buffer's value of default-directory is used.
990 File name components that are `.' are removed, and
991 so are file name components followed by `..', along with the `..' itself;
992 note that these simplifications are done without checking the resulting
993 file names in the file system.
994 An initial `~/' expands to your home directory.
995 An initial `~USER/' expands to USER's home directory.
996 See also the function `substitute-in-file-name'. */)
997 (name
, default_directory
)
998 Lisp_Object name
, default_directory
;
1002 register unsigned char *newdir
, *p
, *o
;
1004 unsigned char *target
;
1007 unsigned char * colon
= 0;
1008 unsigned char * close
= 0;
1009 unsigned char * slash
= 0;
1010 unsigned char * brack
= 0;
1011 int lbrack
= 0, rbrack
= 0;
1016 int collapse_newdir
= 1;
1020 Lisp_Object handler
;
1022 CHECK_STRING (name
);
1024 /* If the file name has special constructs in it,
1025 call the corresponding file handler. */
1026 handler
= Ffind_file_name_handler (name
, Qexpand_file_name
);
1027 if (!NILP (handler
))
1028 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
1030 /* Use the buffer's default-directory if DEFAULT_DIRECTORY is omitted. */
1031 if (NILP (default_directory
))
1032 default_directory
= current_buffer
->directory
;
1033 if (! STRINGP (default_directory
))
1034 default_directory
= build_string ("/");
1036 if (!NILP (default_directory
))
1038 handler
= Ffind_file_name_handler (default_directory
, Qexpand_file_name
);
1039 if (!NILP (handler
))
1040 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
1043 o
= XSTRING (default_directory
)->data
;
1045 /* Make sure DEFAULT_DIRECTORY is properly expanded.
1046 It would be better to do this down below where we actually use
1047 default_directory. Unfortunately, calling Fexpand_file_name recursively
1048 could invoke GC, and the strings might be relocated. This would
1049 be annoying because we have pointers into strings lying around
1050 that would need adjusting, and people would add new pointers to
1051 the code and forget to adjust them, resulting in intermittent bugs.
1052 Putting this call here avoids all that crud.
1054 The EQ test avoids infinite recursion. */
1055 if (! NILP (default_directory
) && !EQ (default_directory
, name
)
1056 /* Save time in some common cases - as long as default_directory
1057 is not relative, it can be canonicalized with name below (if it
1058 is needed at all) without requiring it to be expanded now. */
1060 /* Detect MSDOS file names with drive specifiers. */
1061 && ! (IS_DRIVE (o
[0]) && IS_DEVICE_SEP (o
[1]) && IS_DIRECTORY_SEP (o
[2]))
1063 /* Detect Windows file names in UNC format. */
1064 && ! (IS_DIRECTORY_SEP (o
[0]) && IS_DIRECTORY_SEP (o
[1]))
1066 #else /* not DOS_NT */
1067 /* Detect Unix absolute file names (/... alone is not absolute on
1069 && ! (IS_DIRECTORY_SEP (o
[0]))
1070 #endif /* not DOS_NT */
1073 struct gcpro gcpro1
;
1076 default_directory
= Fexpand_file_name (default_directory
, Qnil
);
1081 /* Filenames on VMS are always upper case. */
1082 name
= Fupcase (name
);
1084 #ifdef FILE_SYSTEM_CASE
1085 name
= FILE_SYSTEM_CASE (name
);
1088 nm
= XSTRING (name
)->data
;
1091 /* We will force directory separators to be either all \ or /, so make
1092 a local copy to modify, even if there ends up being no change. */
1093 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
1095 /* Note if special escape prefix is present, but remove for now. */
1096 if (nm
[0] == '/' && nm
[1] == ':')
1102 /* Find and remove drive specifier if present; this makes nm absolute
1103 even if the rest of the name appears to be relative. Only look for
1104 drive specifier at the beginning. */
1105 if (IS_DRIVE (nm
[0]) && IS_DEVICE_SEP (nm
[1]))
1112 /* If we see "c://somedir", we want to strip the first slash after the
1113 colon when stripping the drive letter. Otherwise, this expands to
1115 if (drive
&& IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1117 #endif /* WINDOWSNT */
1121 /* Discard any previous drive specifier if nm is now in UNC format. */
1122 if (IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1128 /* If nm is absolute, look for `/./' or `/../' or `//''sequences; if
1129 none are found, we can probably return right away. We will avoid
1130 allocating a new string if name is already fully expanded. */
1132 IS_DIRECTORY_SEP (nm
[0])
1134 && drive
&& !is_escaped
1137 && (drive
|| IS_DIRECTORY_SEP (nm
[1])) && !is_escaped
1144 /* If it turns out that the filename we want to return is just a
1145 suffix of FILENAME, we don't need to go through and edit
1146 things; we just need to construct a new string using data
1147 starting at the middle of FILENAME. If we set lose to a
1148 non-zero value, that means we've discovered that we can't do
1155 /* Since we know the name is absolute, we can assume that each
1156 element starts with a "/". */
1158 /* "." and ".." are hairy. */
1159 if (IS_DIRECTORY_SEP (p
[0])
1161 && (IS_DIRECTORY_SEP (p
[2])
1163 || (p
[2] == '.' && (IS_DIRECTORY_SEP (p
[3])
1166 /* We want to replace multiple `/' in a row with a single
1169 && IS_DIRECTORY_SEP (p
[0])
1170 && IS_DIRECTORY_SEP (p
[1]))
1177 /* if dev:[dir]/, move nm to / */
1178 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1179 nm
= (brack
? brack
+ 1 : colon
+ 1);
1180 lbrack
= rbrack
= 0;
1188 /* VMS pre V4.4,convert '-'s in filenames. */
1189 if (lbrack
== rbrack
)
1191 if (dots
< 2) /* this is to allow negative version numbers */
1196 if (lbrack
> rbrack
&&
1197 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1198 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1204 /* count open brackets, reset close bracket pointer */
1205 if (p
[0] == '[' || p
[0] == '<')
1206 lbrack
++, brack
= 0;
1207 /* count close brackets, set close bracket pointer */
1208 if (p
[0] == ']' || p
[0] == '>')
1209 rbrack
++, brack
= p
;
1210 /* detect ][ or >< */
1211 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1213 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1214 nm
= p
+ 1, lose
= 1;
1215 if (p
[0] == ':' && (colon
|| slash
))
1216 /* if dev1:[dir]dev2:, move nm to dev2: */
1222 /* if /name/dev:, move nm to dev: */
1225 /* if node::dev:, move colon following dev */
1226 else if (colon
&& colon
[-1] == ':')
1228 /* if dev1:dev2:, move nm to dev2: */
1229 else if (colon
&& colon
[-1] != ':')
1234 if (p
[0] == ':' && !colon
)
1240 if (lbrack
== rbrack
)
1243 else if (p
[0] == '.')
1251 if (index (nm
, '/'))
1252 return build_string (sys_translate_unix (nm
));
1255 /* Make sure directories are all separated with / or \ as
1256 desired, but avoid allocation of a new string when not
1258 CORRECT_DIR_SEPS (nm
);
1260 if (IS_DIRECTORY_SEP (nm
[1]))
1262 if (strcmp (nm
, XSTRING (name
)->data
) != 0)
1263 name
= build_string (nm
);
1267 /* drive must be set, so this is okay */
1268 if (strcmp (nm
- 2, XSTRING (name
)->data
) != 0)
1270 name
= make_string (nm
- 2, p
- nm
+ 2);
1271 XSTRING (name
)->data
[0] = DRIVE_LETTER (drive
);
1272 XSTRING (name
)->data
[1] = ':';
1275 #else /* not DOS_NT */
1276 if (nm
== XSTRING (name
)->data
)
1278 return build_string (nm
);
1279 #endif /* not DOS_NT */
1283 /* At this point, nm might or might not be an absolute file name. We
1284 need to expand ~ or ~user if present, otherwise prefix nm with
1285 default_directory if nm is not absolute, and finally collapse /./
1286 and /foo/../ sequences.
1288 We set newdir to be the appropriate prefix if one is needed:
1289 - the relevant user directory if nm starts with ~ or ~user
1290 - the specified drive's working dir (DOS/NT only) if nm does not
1292 - the value of default_directory.
1294 Note that these prefixes are not guaranteed to be absolute (except
1295 for the working dir of a drive). Therefore, to ensure we always
1296 return an absolute name, if the final prefix is not absolute we
1297 append it to the current working directory. */
1301 if (nm
[0] == '~') /* prefix ~ */
1303 if (IS_DIRECTORY_SEP (nm
[1])
1307 || nm
[1] == 0) /* ~ by itself */
1309 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1310 newdir
= (unsigned char *) "";
1313 collapse_newdir
= 0;
1316 nm
++; /* Don't leave the slash in nm. */
1319 else /* ~user/filename */
1321 for (p
= nm
; *p
&& (!IS_DIRECTORY_SEP (*p
)
1326 o
= (unsigned char *) alloca (p
- nm
+ 1);
1327 bcopy ((char *) nm
, o
, p
- nm
);
1330 pw
= (struct passwd
*) getpwnam (o
+ 1);
1333 newdir
= (unsigned char *) pw
-> pw_dir
;
1335 nm
= p
+ 1; /* skip the terminator */
1339 collapse_newdir
= 0;
1344 /* If we don't find a user of that name, leave the name
1345 unchanged; don't move nm forward to p. */
1350 /* On DOS and Windows, nm is absolute if a drive name was specified;
1351 use the drive's current directory as the prefix if needed. */
1352 if (!newdir
&& drive
)
1354 /* Get default directory if needed to make nm absolute. */
1355 if (!IS_DIRECTORY_SEP (nm
[0]))
1357 newdir
= alloca (MAXPATHLEN
+ 1);
1358 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1363 /* Either nm starts with /, or drive isn't mounted. */
1364 newdir
= alloca (4);
1365 newdir
[0] = DRIVE_LETTER (drive
);
1373 /* Finally, if no prefix has been specified and nm is not absolute,
1374 then it must be expanded relative to default_directory. */
1378 /* /... alone is not absolute on DOS and Windows. */
1379 && !IS_DIRECTORY_SEP (nm
[0])
1382 && !(IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1389 newdir
= XSTRING (default_directory
)->data
;
1391 /* Note if special escape prefix is present, but remove for now. */
1392 if (newdir
[0] == '/' && newdir
[1] == ':')
1403 /* First ensure newdir is an absolute name. */
1405 /* Detect MSDOS file names with drive specifiers. */
1406 ! (IS_DRIVE (newdir
[0])
1407 && IS_DEVICE_SEP (newdir
[1]) && IS_DIRECTORY_SEP (newdir
[2]))
1409 /* Detect Windows file names in UNC format. */
1410 && ! (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1414 /* Effectively, let newdir be (expand-file-name newdir cwd).
1415 Because of the admonition against calling expand-file-name
1416 when we have pointers into lisp strings, we accomplish this
1417 indirectly by prepending newdir to nm if necessary, and using
1418 cwd (or the wd of newdir's drive) as the new newdir. */
1420 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1425 if (!IS_DIRECTORY_SEP (nm
[0]))
1427 char * tmp
= alloca (strlen (newdir
) + strlen (nm
) + 2);
1428 file_name_as_directory (tmp
, newdir
);
1432 newdir
= alloca (MAXPATHLEN
+ 1);
1435 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1442 /* Strip off drive name from prefix, if present. */
1443 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1449 /* Keep only a prefix from newdir if nm starts with slash
1450 (//server/share for UNC, nothing otherwise). */
1451 if (IS_DIRECTORY_SEP (nm
[0]) && collapse_newdir
)
1454 if (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1456 newdir
= strcpy (alloca (strlen (newdir
) + 1), newdir
);
1458 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1460 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1472 /* Get rid of any slash at the end of newdir, unless newdir is
1473 just / or // (an incomplete UNC name). */
1474 length
= strlen (newdir
);
1475 if (length
> 1 && IS_DIRECTORY_SEP (newdir
[length
- 1])
1477 && !(length
== 2 && IS_DIRECTORY_SEP (newdir
[0]))
1481 unsigned char *temp
= (unsigned char *) alloca (length
);
1482 bcopy (newdir
, temp
, length
- 1);
1483 temp
[length
- 1] = 0;
1491 /* Now concatenate the directory and name to new space in the stack frame */
1492 tlen
+= strlen (nm
) + 1;
1494 /* Reserve space for drive specifier and escape prefix, since either
1495 or both may need to be inserted. (The Microsoft x86 compiler
1496 produces incorrect code if the following two lines are combined.) */
1497 target
= (unsigned char *) alloca (tlen
+ 4);
1499 #else /* not DOS_NT */
1500 target
= (unsigned char *) alloca (tlen
);
1501 #endif /* not DOS_NT */
1507 if (nm
[0] == 0 || IS_DIRECTORY_SEP (nm
[0]))
1510 /* If newdir is effectively "C:/", then the drive letter will have
1511 been stripped and newdir will be "/". Concatenating with an
1512 absolute directory in nm produces "//", which will then be
1513 incorrectly treated as a network share. Ignore newdir in
1514 this case (keeping the drive letter). */
1515 if (!(drive
&& nm
[0] && IS_DIRECTORY_SEP (newdir
[0])
1516 && newdir
[1] == '\0'))
1518 strcpy (target
, newdir
);
1522 file_name_as_directory (target
, newdir
);
1525 strcat (target
, nm
);
1527 if (index (target
, '/'))
1528 strcpy (target
, sys_translate_unix (target
));
1531 /* ASSERT (IS_DIRECTORY_SEP (target[0])) if not VMS */
1533 /* Now canonicalize by removing `//', `/.' and `/foo/..' if they
1542 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1548 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1549 /* brackets are offset from each other by 2 */
1552 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1553 /* convert [foo][bar] to [bar] */
1554 while (o
[-1] != '[' && o
[-1] != '<')
1556 else if (*p
== '-' && *o
!= '.')
1559 else if (p
[0] == '-' && o
[-1] == '.' &&
1560 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1561 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1565 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1566 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1568 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1570 /* else [foo.-] ==> [-] */
1576 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1577 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1583 if (!IS_DIRECTORY_SEP (*p
))
1587 else if (IS_DIRECTORY_SEP (p
[0])
1589 && (IS_DIRECTORY_SEP (p
[2])
1592 /* If "/." is the entire filename, keep the "/". Otherwise,
1593 just delete the whole "/.". */
1594 if (o
== target
&& p
[2] == '\0')
1598 else if (IS_DIRECTORY_SEP (p
[0]) && p
[1] == '.' && p
[2] == '.'
1599 /* `/../' is the "superroot" on certain file systems. */
1601 && (IS_DIRECTORY_SEP (p
[3]) || p
[3] == 0))
1603 while (o
!= target
&& (--o
) && !IS_DIRECTORY_SEP (*o
))
1605 /* Keep initial / only if this is the whole name. */
1606 if (o
== target
&& IS_ANY_SEP (*o
) && p
[3] == 0)
1611 && IS_DIRECTORY_SEP (p
[0]) && IS_DIRECTORY_SEP (p
[1]))
1613 /* Collapse multiple `/' in a row. */
1615 while (IS_DIRECTORY_SEP (*p
))
1622 #endif /* not VMS */
1626 /* At last, set drive name. */
1628 /* Except for network file name. */
1629 if (!(IS_DIRECTORY_SEP (target
[0]) && IS_DIRECTORY_SEP (target
[1])))
1630 #endif /* WINDOWSNT */
1632 if (!drive
) abort ();
1634 target
[0] = DRIVE_LETTER (drive
);
1637 /* Reinsert the escape prefix if required. */
1644 CORRECT_DIR_SEPS (target
);
1647 return make_string (target
, o
- target
);
1651 /* PLEASE DO NOT DELETE THIS COMMENTED-OUT VERSION!
1652 This is the old version of expand-file-name, before it was thoroughly
1653 rewritten for Emacs 10.31. We leave this version here commented-out,
1654 because the code is very complex and likely to have subtle bugs. If
1655 bugs _are_ found, it might be of interest to look at the old code and
1656 see what did it do in the relevant situation.
1658 Don't remove this code: it's true that it will be accessible via CVS,
1659 but a few years from deletion, people will forget it is there. */
1661 /* Changed this DEFUN to a DEAFUN, so as not to confuse `make-docfile'. */
1662 DEAFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
1663 "Convert FILENAME to absolute, and canonicalize it.\n\
1664 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
1665 (does not start with slash); if DEFAULT is nil or missing,\n\
1666 the current buffer's value of default-directory is used.\n\
1667 Filenames containing `.' or `..' as components are simplified;\n\
1668 initial `~/' expands to your home directory.\n\
1669 See also the function `substitute-in-file-name'.")
1671 Lisp_Object name
, defalt
;
1675 register unsigned char *newdir
, *p
, *o
;
1677 unsigned char *target
;
1681 unsigned char * colon
= 0;
1682 unsigned char * close
= 0;
1683 unsigned char * slash
= 0;
1684 unsigned char * brack
= 0;
1685 int lbrack
= 0, rbrack
= 0;
1689 CHECK_STRING (name
);
1692 /* Filenames on VMS are always upper case. */
1693 name
= Fupcase (name
);
1696 nm
= XSTRING (name
)->data
;
1698 /* If nm is absolute, flush ...// and detect /./ and /../.
1699 If no /./ or /../ we can return right away. */
1711 if (p
[0] == '/' && p
[1] == '/'
1713 /* // at start of filename is meaningful on Apollo system. */
1718 if (p
[0] == '/' && p
[1] == '~')
1719 nm
= p
+ 1, lose
= 1;
1720 if (p
[0] == '/' && p
[1] == '.'
1721 && (p
[2] == '/' || p
[2] == 0
1722 || (p
[2] == '.' && (p
[3] == '/' || p
[3] == 0))))
1728 /* if dev:[dir]/, move nm to / */
1729 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1730 nm
= (brack
? brack
+ 1 : colon
+ 1);
1731 lbrack
= rbrack
= 0;
1739 /* VMS pre V4.4,convert '-'s in filenames. */
1740 if (lbrack
== rbrack
)
1742 if (dots
< 2) /* this is to allow negative version numbers */
1747 if (lbrack
> rbrack
&&
1748 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1749 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1755 /* count open brackets, reset close bracket pointer */
1756 if (p
[0] == '[' || p
[0] == '<')
1757 lbrack
++, brack
= 0;
1758 /* count close brackets, set close bracket pointer */
1759 if (p
[0] == ']' || p
[0] == '>')
1760 rbrack
++, brack
= p
;
1761 /* detect ][ or >< */
1762 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1764 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1765 nm
= p
+ 1, lose
= 1;
1766 if (p
[0] == ':' && (colon
|| slash
))
1767 /* if dev1:[dir]dev2:, move nm to dev2: */
1773 /* If /name/dev:, move nm to dev: */
1776 /* If node::dev:, move colon following dev */
1777 else if (colon
&& colon
[-1] == ':')
1779 /* If dev1:dev2:, move nm to dev2: */
1780 else if (colon
&& colon
[-1] != ':')
1785 if (p
[0] == ':' && !colon
)
1791 if (lbrack
== rbrack
)
1794 else if (p
[0] == '.')
1802 if (index (nm
, '/'))
1803 return build_string (sys_translate_unix (nm
));
1805 if (nm
== XSTRING (name
)->data
)
1807 return build_string (nm
);
1811 /* Now determine directory to start with and put it in NEWDIR */
1815 if (nm
[0] == '~') /* prefix ~ */
1820 || nm
[1] == 0)/* ~/filename */
1822 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1823 newdir
= (unsigned char *) "";
1826 nm
++; /* Don't leave the slash in nm. */
1829 else /* ~user/filename */
1831 /* Get past ~ to user */
1832 unsigned char *user
= nm
+ 1;
1833 /* Find end of name. */
1834 unsigned char *ptr
= (unsigned char *) index (user
, '/');
1835 int len
= ptr
? ptr
- user
: strlen (user
);
1837 unsigned char *ptr1
= index (user
, ':');
1838 if (ptr1
!= 0 && ptr1
- user
< len
)
1841 /* Copy the user name into temp storage. */
1842 o
= (unsigned char *) alloca (len
+ 1);
1843 bcopy ((char *) user
, o
, len
);
1846 /* Look up the user name. */
1847 pw
= (struct passwd
*) getpwnam (o
+ 1);
1849 error ("\"%s\" isn't a registered user", o
+ 1);
1851 newdir
= (unsigned char *) pw
->pw_dir
;
1853 /* Discard the user name from NM. */
1860 #endif /* not VMS */
1864 defalt
= current_buffer
->directory
;
1865 CHECK_STRING (defalt
);
1866 newdir
= XSTRING (defalt
)->data
;
1869 /* Now concatenate the directory and name to new space in the stack frame */
1871 tlen
= (newdir
? strlen (newdir
) + 1 : 0) + strlen (nm
) + 1;
1872 target
= (unsigned char *) alloca (tlen
);
1878 if (nm
[0] == 0 || nm
[0] == '/')
1879 strcpy (target
, newdir
);
1882 file_name_as_directory (target
, newdir
);
1885 strcat (target
, nm
);
1887 if (index (target
, '/'))
1888 strcpy (target
, sys_translate_unix (target
));
1891 /* Now canonicalize by removing /. and /foo/.. if they appear */
1899 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1905 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1906 /* brackets are offset from each other by 2 */
1909 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1910 /* convert [foo][bar] to [bar] */
1911 while (o
[-1] != '[' && o
[-1] != '<')
1913 else if (*p
== '-' && *o
!= '.')
1916 else if (p
[0] == '-' && o
[-1] == '.' &&
1917 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1918 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1922 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1923 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1925 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1927 /* else [foo.-] ==> [-] */
1933 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1934 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1944 else if (!strncmp (p
, "//", 2)
1946 /* // at start of filename is meaningful in Apollo system. */
1954 else if (p
[0] == '/' && p
[1] == '.' &&
1955 (p
[2] == '/' || p
[2] == 0))
1957 else if (!strncmp (p
, "/..", 3)
1958 /* `/../' is the "superroot" on certain file systems. */
1960 && (p
[3] == '/' || p
[3] == 0))
1962 while (o
!= target
&& *--o
!= '/')
1965 if (o
== target
+ 1 && o
[-1] == '/' && o
[0] == '/')
1969 if (o
== target
&& *o
== '/')
1977 #endif /* not VMS */
1980 return make_string (target
, o
- target
);
1984 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name
,
1985 Ssubstitute_in_file_name
, 1, 1, 0,
1986 doc
: /* Substitute environment variables referred to in FILENAME.
1987 `$FOO' where FOO is an environment variable name means to substitute
1988 the value of that variable. The variable name should be terminated
1989 with a character not a letter, digit or underscore; otherwise, enclose
1990 the entire variable name in braces.
1991 If `/~' appears, all of FILENAME through that `/' is discarded.
1993 On VMS, `$' substitution is not done; this function does little and only
1994 duplicates what `expand-file-name' does. */)
1996 Lisp_Object filename
;
2000 register unsigned char *s
, *p
, *o
, *x
, *endp
;
2001 unsigned char *target
= NULL
;
2003 int substituted
= 0;
2005 Lisp_Object handler
;
2007 CHECK_STRING (filename
);
2009 /* If the file name has special constructs in it,
2010 call the corresponding file handler. */
2011 handler
= Ffind_file_name_handler (filename
, Qsubstitute_in_file_name
);
2012 if (!NILP (handler
))
2013 return call2 (handler
, Qsubstitute_in_file_name
, filename
);
2015 nm
= XSTRING (filename
)->data
;
2017 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
2018 CORRECT_DIR_SEPS (nm
);
2019 substituted
= (strcmp (nm
, XSTRING (filename
)->data
) != 0);
2021 endp
= nm
+ STRING_BYTES (XSTRING (filename
));
2023 /* If /~ or // appears, discard everything through first slash. */
2025 for (p
= nm
; p
!= endp
; p
++)
2028 #if defined (APOLLO) || defined (WINDOWSNT)
2029 /* // at start of file name is meaningful in Apollo and
2030 WindowsNT systems. */
2031 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != nm
)
2032 #else /* not (APOLLO || WINDOWSNT) */
2033 || IS_DIRECTORY_SEP (p
[0])
2034 #endif /* not (APOLLO || WINDOWSNT) */
2039 || p
[-1] == ':' || p
[-1] == ']' || p
[-1] == '>'
2041 || IS_DIRECTORY_SEP (p
[-1])))
2047 /* see comment in expand-file-name about drive specifiers */
2048 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
2049 && p
> nm
&& IS_DIRECTORY_SEP (p
[-1]))
2058 return build_string (nm
);
2061 /* See if any variables are substituted into the string
2062 and find the total length of their values in `total' */
2064 for (p
= nm
; p
!= endp
;)
2074 /* "$$" means a single "$" */
2083 while (p
!= endp
&& *p
!= '}') p
++;
2084 if (*p
!= '}') goto missingclose
;
2090 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
2094 /* Copy out the variable name */
2095 target
= (unsigned char *) alloca (s
- o
+ 1);
2096 strncpy (target
, o
, s
- o
);
2099 strupr (target
); /* $home == $HOME etc. */
2102 /* Get variable value */
2103 o
= (unsigned char *) egetenv (target
);
2104 if (!o
) goto badvar
;
2105 total
+= strlen (o
);
2112 /* If substitution required, recopy the string and do it */
2113 /* Make space in stack frame for the new copy */
2114 xnm
= (unsigned char *) alloca (STRING_BYTES (XSTRING (filename
)) + total
+ 1);
2117 /* Copy the rest of the name through, replacing $ constructs with values */
2134 while (p
!= endp
&& *p
!= '}') p
++;
2135 if (*p
!= '}') goto missingclose
;
2141 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
2145 /* Copy out the variable name */
2146 target
= (unsigned char *) alloca (s
- o
+ 1);
2147 strncpy (target
, o
, s
- o
);
2150 strupr (target
); /* $home == $HOME etc. */
2153 /* Get variable value */
2154 o
= (unsigned char *) egetenv (target
);
2158 if (STRING_MULTIBYTE (filename
))
2160 /* If the original string is multibyte,
2161 convert what we substitute into multibyte. */
2164 int c
= unibyte_char_to_multibyte (*o
++);
2165 x
+= CHAR_STRING (c
, x
);
2177 /* If /~ or // appears, discard everything through first slash. */
2179 for (p
= xnm
; p
!= x
; p
++)
2181 #if defined (APOLLO) || defined (WINDOWSNT)
2182 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != xnm
)
2183 #else /* not (APOLLO || WINDOWSNT) */
2184 || IS_DIRECTORY_SEP (p
[0])
2185 #endif /* not (APOLLO || WINDOWSNT) */
2187 && p
!= xnm
&& IS_DIRECTORY_SEP (p
[-1]))
2190 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
2191 && p
> xnm
&& IS_DIRECTORY_SEP (p
[-1]))
2195 if (STRING_MULTIBYTE (filename
))
2196 return make_string (xnm
, x
- xnm
);
2197 return make_unibyte_string (xnm
, x
- xnm
);
2200 error ("Bad format environment-variable substitution");
2202 error ("Missing \"}\" in environment-variable substitution");
2204 error ("Substituting nonexistent environment variable \"%s\"", target
);
2207 #endif /* not VMS */
2211 /* A slightly faster and more convenient way to get
2212 (directory-file-name (expand-file-name FOO)). */
2215 expand_and_dir_to_file (filename
, defdir
)
2216 Lisp_Object filename
, defdir
;
2218 register Lisp_Object absname
;
2220 absname
= Fexpand_file_name (filename
, defdir
);
2223 register int c
= XSTRING (absname
)->data
[STRING_BYTES (XSTRING (absname
)) - 1];
2224 if (c
== ':' || c
== ']' || c
== '>')
2225 absname
= Fdirectory_file_name (absname
);
2228 /* Remove final slash, if any (unless this is the root dir).
2229 stat behaves differently depending! */
2230 if (XSTRING (absname
)->size
> 1
2231 && IS_DIRECTORY_SEP (XSTRING (absname
)->data
[STRING_BYTES (XSTRING (absname
)) - 1])
2232 && !IS_DEVICE_SEP (XSTRING (absname
)->data
[STRING_BYTES (XSTRING (absname
))-2]))
2233 /* We cannot take shortcuts; they might be wrong for magic file names. */
2234 absname
= Fdirectory_file_name (absname
);
2239 /* Signal an error if the file ABSNAME already exists.
2240 If INTERACTIVE is nonzero, ask the user whether to proceed,
2241 and bypass the error if the user says to go ahead.
2242 QUERYSTRING is a name for the action that is being considered
2245 *STATPTR is used to store the stat information if the file exists.
2246 If the file does not exist, STATPTR->st_mode is set to 0.
2247 If STATPTR is null, we don't store into it.
2249 If QUICK is nonzero, we ask for y or n, not yes or no. */
2252 barf_or_query_if_file_exists (absname
, querystring
, interactive
, statptr
, quick
)
2253 Lisp_Object absname
;
2254 unsigned char *querystring
;
2256 struct stat
*statptr
;
2259 register Lisp_Object tem
, encoded_filename
;
2260 struct stat statbuf
;
2261 struct gcpro gcpro1
;
2263 encoded_filename
= ENCODE_FILE (absname
);
2265 /* stat is a good way to tell whether the file exists,
2266 regardless of what access permissions it has. */
2267 if (stat (XSTRING (encoded_filename
)->data
, &statbuf
) >= 0)
2270 Fsignal (Qfile_already_exists
,
2271 Fcons (build_string ("File already exists"),
2272 Fcons (absname
, Qnil
)));
2274 tem
= format1 ("File %s already exists; %s anyway? ",
2275 XSTRING (absname
)->data
, querystring
);
2277 tem
= Fy_or_n_p (tem
);
2279 tem
= do_yes_or_no_p (tem
);
2282 Fsignal (Qfile_already_exists
,
2283 Fcons (build_string ("File already exists"),
2284 Fcons (absname
, Qnil
)));
2291 statptr
->st_mode
= 0;
2296 DEFUN ("copy-file", Fcopy_file
, Scopy_file
, 2, 4,
2297 "fCopy file: \nFCopy %s to file: \np\nP",
2298 doc
: /* Copy FILE to NEWNAME. Both args must be strings.
2299 If NEWNAME names a directory, copy FILE there.
2300 Signals a `file-already-exists' error if file NEWNAME already exists,
2301 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.
2302 A number as third arg means request confirmation if NEWNAME already exists.
2303 This is what happens in interactive use with M-x.
2304 Fourth arg KEEP-TIME non-nil means give the new file the same
2305 last-modified time as the old one. (This works on only some systems.)
2306 A prefix arg makes KEEP-TIME non-nil. */)
2307 (file
, newname
, ok_if_already_exists
, keep_time
)
2308 Lisp_Object file
, newname
, ok_if_already_exists
, keep_time
;
2311 char buf
[16 * 1024];
2312 struct stat st
, out_st
;
2313 Lisp_Object handler
;
2314 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2315 int count
= specpdl_ptr
- specpdl
;
2316 int input_file_statable_p
;
2317 Lisp_Object encoded_file
, encoded_newname
;
2319 encoded_file
= encoded_newname
= Qnil
;
2320 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2321 CHECK_STRING (file
);
2322 CHECK_STRING (newname
);
2324 if (!NILP (Ffile_directory_p (newname
)))
2325 newname
= Fexpand_file_name (file
, newname
);
2327 newname
= Fexpand_file_name (newname
, Qnil
);
2329 file
= Fexpand_file_name (file
, Qnil
);
2331 /* If the input file name has special constructs in it,
2332 call the corresponding file handler. */
2333 handler
= Ffind_file_name_handler (file
, Qcopy_file
);
2334 /* Likewise for output file name. */
2336 handler
= Ffind_file_name_handler (newname
, Qcopy_file
);
2337 if (!NILP (handler
))
2338 RETURN_UNGCPRO (call5 (handler
, Qcopy_file
, file
, newname
,
2339 ok_if_already_exists
, keep_time
));
2341 encoded_file
= ENCODE_FILE (file
);
2342 encoded_newname
= ENCODE_FILE (newname
);
2344 if (NILP (ok_if_already_exists
)
2345 || INTEGERP (ok_if_already_exists
))
2346 barf_or_query_if_file_exists (encoded_newname
, "copy to it",
2347 INTEGERP (ok_if_already_exists
), &out_st
, 0);
2348 else if (stat (XSTRING (encoded_newname
)->data
, &out_st
) < 0)
2352 if (!CopyFile (XSTRING (encoded_file
)->data
,
2353 XSTRING (encoded_newname
)->data
,
2355 report_file_error ("Copying file", Fcons (file
, Fcons (newname
, Qnil
)));
2356 else if (NILP (keep_time
))
2359 EMACS_GET_TIME (now
);
2360 if (set_file_times (XSTRING (encoded_newname
)->data
,
2362 Fsignal (Qfile_date_error
,
2363 Fcons (build_string ("Cannot set file date"),
2364 Fcons (newname
, Qnil
)));
2366 #else /* not WINDOWSNT */
2367 ifd
= emacs_open (XSTRING (encoded_file
)->data
, O_RDONLY
, 0);
2369 report_file_error ("Opening input file", Fcons (file
, Qnil
));
2371 record_unwind_protect (close_file_unwind
, make_number (ifd
));
2373 /* We can only copy regular files and symbolic links. Other files are not
2375 input_file_statable_p
= (fstat (ifd
, &st
) >= 0);
2377 #if !defined (DOS_NT) || __DJGPP__ > 1
2378 if (out_st
.st_mode
!= 0
2379 && st
.st_dev
== out_st
.st_dev
&& st
.st_ino
== out_st
.st_ino
)
2382 report_file_error ("Input and output files are the same",
2383 Fcons (file
, Fcons (newname
, Qnil
)));
2387 #if defined (S_ISREG) && defined (S_ISLNK)
2388 if (input_file_statable_p
)
2390 if (!(S_ISREG (st
.st_mode
)) && !(S_ISLNK (st
.st_mode
)))
2392 #if defined (EISDIR)
2393 /* Get a better looking error message. */
2396 report_file_error ("Non-regular file", Fcons (file
, Qnil
));
2399 #endif /* S_ISREG && S_ISLNK */
2402 /* Create the copy file with the same record format as the input file */
2403 ofd
= sys_creat (XSTRING (encoded_newname
)->data
, 0666, ifd
);
2406 /* System's default file type was set to binary by _fmode in emacs.c. */
2407 ofd
= creat (XSTRING (encoded_newname
)->data
, S_IREAD
| S_IWRITE
);
2408 #else /* not MSDOS */
2409 ofd
= creat (XSTRING (encoded_newname
)->data
, 0666);
2410 #endif /* not MSDOS */
2413 report_file_error ("Opening output file", Fcons (newname
, Qnil
));
2415 record_unwind_protect (close_file_unwind
, make_number (ofd
));
2419 while ((n
= emacs_read (ifd
, buf
, sizeof buf
)) > 0)
2420 if (emacs_write (ofd
, buf
, n
) != n
)
2421 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2424 /* Closing the output clobbers the file times on some systems. */
2425 if (emacs_close (ofd
) < 0)
2426 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2428 if (input_file_statable_p
)
2430 if (!NILP (keep_time
))
2432 EMACS_TIME atime
, mtime
;
2433 EMACS_SET_SECS_USECS (atime
, st
.st_atime
, 0);
2434 EMACS_SET_SECS_USECS (mtime
, st
.st_mtime
, 0);
2435 if (set_file_times (XSTRING (encoded_newname
)->data
,
2437 Fsignal (Qfile_date_error
,
2438 Fcons (build_string ("Cannot set file date"),
2439 Fcons (newname
, Qnil
)));
2442 chmod (XSTRING (encoded_newname
)->data
, st
.st_mode
& 07777);
2444 #if defined (__DJGPP__) && __DJGPP__ > 1
2445 /* In DJGPP v2.0 and later, fstat usually returns true file mode bits,
2446 and if it can't, it tells so. Otherwise, under MSDOS we usually
2447 get only the READ bit, which will make the copied file read-only,
2448 so it's better not to chmod at all. */
2449 if ((_djstat_flags
& _STFAIL_WRITEBIT
) == 0)
2450 chmod (XSTRING (encoded_newname
)->data
, st
.st_mode
& 07777);
2451 #endif /* DJGPP version 2 or newer */
2456 #endif /* WINDOWSNT */
2458 /* Discard the unwind protects. */
2459 specpdl_ptr
= specpdl
+ count
;
2465 DEFUN ("make-directory-internal", Fmake_directory_internal
,
2466 Smake_directory_internal
, 1, 1, 0,
2467 doc
: /* Create a new directory named DIRECTORY. */)
2469 Lisp_Object directory
;
2472 Lisp_Object handler
;
2473 Lisp_Object encoded_dir
;
2475 CHECK_STRING (directory
);
2476 directory
= Fexpand_file_name (directory
, Qnil
);
2478 handler
= Ffind_file_name_handler (directory
, Qmake_directory_internal
);
2479 if (!NILP (handler
))
2480 return call2 (handler
, Qmake_directory_internal
, directory
);
2482 encoded_dir
= ENCODE_FILE (directory
);
2484 dir
= XSTRING (encoded_dir
)->data
;
2487 if (mkdir (dir
) != 0)
2489 if (mkdir (dir
, 0777) != 0)
2491 report_file_error ("Creating directory", Flist (1, &directory
));
2496 DEFUN ("delete-directory", Fdelete_directory
, Sdelete_directory
, 1, 1, "FDelete directory: ",
2497 doc
: /* Delete the directory named DIRECTORY. */)
2499 Lisp_Object directory
;
2502 Lisp_Object handler
;
2503 Lisp_Object encoded_dir
;
2505 CHECK_STRING (directory
);
2506 directory
= Fdirectory_file_name (Fexpand_file_name (directory
, Qnil
));
2508 handler
= Ffind_file_name_handler (directory
, Qdelete_directory
);
2509 if (!NILP (handler
))
2510 return call2 (handler
, Qdelete_directory
, directory
);
2512 encoded_dir
= ENCODE_FILE (directory
);
2514 dir
= XSTRING (encoded_dir
)->data
;
2516 if (rmdir (dir
) != 0)
2517 report_file_error ("Removing directory", Flist (1, &directory
));
2522 DEFUN ("delete-file", Fdelete_file
, Sdelete_file
, 1, 1, "fDelete file: ",
2523 doc
: /* Delete file named FILENAME.
2524 If file has multiple names, it continues to exist with the other names. */)
2526 Lisp_Object filename
;
2528 Lisp_Object handler
;
2529 Lisp_Object encoded_file
;
2531 CHECK_STRING (filename
);
2532 filename
= Fexpand_file_name (filename
, Qnil
);
2534 handler
= Ffind_file_name_handler (filename
, Qdelete_file
);
2535 if (!NILP (handler
))
2536 return call2 (handler
, Qdelete_file
, filename
);
2538 encoded_file
= ENCODE_FILE (filename
);
2540 if (0 > unlink (XSTRING (encoded_file
)->data
))
2541 report_file_error ("Removing old name", Flist (1, &filename
));
2546 internal_delete_file_1 (ignore
)
2552 /* Delete file FILENAME, returning 1 if successful and 0 if failed. */
2555 internal_delete_file (filename
)
2556 Lisp_Object filename
;
2558 return NILP (internal_condition_case_1 (Fdelete_file
, filename
,
2559 Qt
, internal_delete_file_1
));
2562 DEFUN ("rename-file", Frename_file
, Srename_file
, 2, 3,
2563 "fRename file: \nFRename %s to file: \np",
2564 doc
: /* Rename FILE as NEWNAME. Both args strings.
2565 If file has names other than FILE, it continues to have those names.
2566 Signals a `file-already-exists' error if a file NEWNAME already exists
2567 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
2568 A number as third arg means request confirmation if NEWNAME already exists.
2569 This is what happens in interactive use with M-x. */)
2570 (file
, newname
, ok_if_already_exists
)
2571 Lisp_Object file
, newname
, ok_if_already_exists
;
2574 Lisp_Object args
[2];
2576 Lisp_Object handler
;
2577 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2578 Lisp_Object encoded_file
, encoded_newname
;
2580 encoded_file
= encoded_newname
= Qnil
;
2581 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2582 CHECK_STRING (file
);
2583 CHECK_STRING (newname
);
2584 file
= Fexpand_file_name (file
, Qnil
);
2585 newname
= Fexpand_file_name (newname
, Qnil
);
2587 /* If the file name has special constructs in it,
2588 call the corresponding file handler. */
2589 handler
= Ffind_file_name_handler (file
, Qrename_file
);
2591 handler
= Ffind_file_name_handler (newname
, Qrename_file
);
2592 if (!NILP (handler
))
2593 RETURN_UNGCPRO (call4 (handler
, Qrename_file
,
2594 file
, newname
, ok_if_already_exists
));
2596 encoded_file
= ENCODE_FILE (file
);
2597 encoded_newname
= ENCODE_FILE (newname
);
2600 /* If the file names are identical but for the case, don't ask for
2601 confirmation: they simply want to change the letter-case of the
2603 if (NILP (Fstring_equal (Fdowncase (file
), Fdowncase (newname
))))
2605 if (NILP (ok_if_already_exists
)
2606 || INTEGERP (ok_if_already_exists
))
2607 barf_or_query_if_file_exists (encoded_newname
, "rename to it",
2608 INTEGERP (ok_if_already_exists
), 0, 0);
2610 if (0 > rename (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
))
2612 if (0 > link (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
)
2613 || 0 > unlink (XSTRING (encoded_file
)->data
))
2618 Fcopy_file (file
, newname
,
2619 /* We have already prompted if it was an integer,
2620 so don't have copy-file prompt again. */
2621 NILP (ok_if_already_exists
) ? Qnil
: Qt
, Qt
);
2622 Fdelete_file (file
);
2629 report_file_error ("Renaming", Flist (2, args
));
2632 report_file_error ("Renaming", Flist (2, &file
));
2639 DEFUN ("add-name-to-file", Fadd_name_to_file
, Sadd_name_to_file
, 2, 3,
2640 "fAdd name to file: \nFName to add to %s: \np",
2641 doc
: /* Give FILE additional name NEWNAME. Both args strings.
2642 Signals a `file-already-exists' error if a file NEWNAME already exists
2643 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
2644 A number as third arg means request confirmation if NEWNAME already exists.
2645 This is what happens in interactive use with M-x. */)
2646 (file
, newname
, ok_if_already_exists
)
2647 Lisp_Object file
, newname
, ok_if_already_exists
;
2650 Lisp_Object args
[2];
2652 Lisp_Object handler
;
2653 Lisp_Object encoded_file
, encoded_newname
;
2654 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2656 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2657 encoded_file
= encoded_newname
= Qnil
;
2658 CHECK_STRING (file
);
2659 CHECK_STRING (newname
);
2660 file
= Fexpand_file_name (file
, Qnil
);
2661 newname
= Fexpand_file_name (newname
, Qnil
);
2663 /* If the file name has special constructs in it,
2664 call the corresponding file handler. */
2665 handler
= Ffind_file_name_handler (file
, Qadd_name_to_file
);
2666 if (!NILP (handler
))
2667 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2668 newname
, ok_if_already_exists
));
2670 /* If the new name has special constructs in it,
2671 call the corresponding file handler. */
2672 handler
= Ffind_file_name_handler (newname
, Qadd_name_to_file
);
2673 if (!NILP (handler
))
2674 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2675 newname
, ok_if_already_exists
));
2677 encoded_file
= ENCODE_FILE (file
);
2678 encoded_newname
= ENCODE_FILE (newname
);
2680 if (NILP (ok_if_already_exists
)
2681 || INTEGERP (ok_if_already_exists
))
2682 barf_or_query_if_file_exists (encoded_newname
, "make it a new name",
2683 INTEGERP (ok_if_already_exists
), 0, 0);
2685 unlink (XSTRING (newname
)->data
);
2686 if (0 > link (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
))
2691 report_file_error ("Adding new name", Flist (2, args
));
2693 report_file_error ("Adding new name", Flist (2, &file
));
2702 DEFUN ("make-symbolic-link", Fmake_symbolic_link
, Smake_symbolic_link
, 2, 3,
2703 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np",
2704 doc
: /* Make a symbolic link to FILENAME, named LINKNAME. Both args strings.
2705 Signals a `file-already-exists' error if a file LINKNAME already exists
2706 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
2707 A number as third arg means request confirmation if LINKNAME already exists.
2708 This happens for interactive use with M-x. */)
2709 (filename
, linkname
, ok_if_already_exists
)
2710 Lisp_Object filename
, linkname
, ok_if_already_exists
;
2713 Lisp_Object args
[2];
2715 Lisp_Object handler
;
2716 Lisp_Object encoded_filename
, encoded_linkname
;
2717 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2719 GCPRO4 (filename
, linkname
, encoded_filename
, encoded_linkname
);
2720 encoded_filename
= encoded_linkname
= Qnil
;
2721 CHECK_STRING (filename
);
2722 CHECK_STRING (linkname
);
2723 /* If the link target has a ~, we must expand it to get
2724 a truly valid file name. Otherwise, do not expand;
2725 we want to permit links to relative file names. */
2726 if (XSTRING (filename
)->data
[0] == '~')
2727 filename
= Fexpand_file_name (filename
, Qnil
);
2728 linkname
= Fexpand_file_name (linkname
, Qnil
);
2730 /* If the file name has special constructs in it,
2731 call the corresponding file handler. */
2732 handler
= Ffind_file_name_handler (filename
, Qmake_symbolic_link
);
2733 if (!NILP (handler
))
2734 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2735 linkname
, ok_if_already_exists
));
2737 /* If the new link name has special constructs in it,
2738 call the corresponding file handler. */
2739 handler
= Ffind_file_name_handler (linkname
, Qmake_symbolic_link
);
2740 if (!NILP (handler
))
2741 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2742 linkname
, ok_if_already_exists
));
2744 encoded_filename
= ENCODE_FILE (filename
);
2745 encoded_linkname
= ENCODE_FILE (linkname
);
2747 if (NILP (ok_if_already_exists
)
2748 || INTEGERP (ok_if_already_exists
))
2749 barf_or_query_if_file_exists (encoded_linkname
, "make it a link",
2750 INTEGERP (ok_if_already_exists
), 0, 0);
2751 if (0 > symlink (XSTRING (encoded_filename
)->data
,
2752 XSTRING (encoded_linkname
)->data
))
2754 /* If we didn't complain already, silently delete existing file. */
2755 if (errno
== EEXIST
)
2757 unlink (XSTRING (encoded_linkname
)->data
);
2758 if (0 <= symlink (XSTRING (encoded_filename
)->data
,
2759 XSTRING (encoded_linkname
)->data
))
2769 report_file_error ("Making symbolic link", Flist (2, args
));
2771 report_file_error ("Making symbolic link", Flist (2, &filename
));
2777 #endif /* S_IFLNK */
2781 DEFUN ("define-logical-name", Fdefine_logical_name
, Sdefine_logical_name
,
2782 2, 2, "sDefine logical name: \nsDefine logical name %s as: ",
2783 doc
: /* Define the job-wide logical name NAME to have the value STRING.
2784 If STRING is nil or a null string, the logical name NAME is deleted. */)
2789 CHECK_STRING (name
);
2791 delete_logical_name (XSTRING (name
)->data
);
2794 CHECK_STRING (string
);
2796 if (XSTRING (string
)->size
== 0)
2797 delete_logical_name (XSTRING (name
)->data
);
2799 define_logical_name (XSTRING (name
)->data
, XSTRING (string
)->data
);
2808 DEFUN ("sysnetunam", Fsysnetunam
, Ssysnetunam
, 2, 2, 0,
2809 doc
: /* Open a network connection to PATH using LOGIN as the login string. */)
2811 Lisp_Object path
, login
;
2815 CHECK_STRING (path
);
2816 CHECK_STRING (login
);
2818 netresult
= netunam (XSTRING (path
)->data
, XSTRING (login
)->data
);
2820 if (netresult
== -1)
2825 #endif /* HPUX_NET */
2827 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p
, Sfile_name_absolute_p
,
2829 doc
: /* Return t if file FILENAME specifies an absolute file name.
2830 On Unix, this is a name starting with a `/' or a `~'. */)
2832 Lisp_Object filename
;
2836 CHECK_STRING (filename
);
2837 ptr
= XSTRING (filename
)->data
;
2838 if (IS_DIRECTORY_SEP (*ptr
) || *ptr
== '~'
2840 /* ??? This criterion is probably wrong for '<'. */
2841 || index (ptr
, ':') || index (ptr
, '<')
2842 || (*ptr
== '[' && (ptr
[1] != '-' || (ptr
[2] != '.' && ptr
[2] != ']'))
2846 || (IS_DRIVE (*ptr
) && ptr
[1] == ':' && IS_DIRECTORY_SEP (ptr
[2]))
2854 /* Return nonzero if file FILENAME exists and can be executed. */
2857 check_executable (filename
)
2861 int len
= strlen (filename
);
2864 if (stat (filename
, &st
) < 0)
2866 #if defined (WINDOWSNT) || (defined (MSDOS) && __DJGPP__ > 1)
2867 return ((st
.st_mode
& S_IEXEC
) != 0);
2869 return (S_ISREG (st
.st_mode
)
2871 && (stricmp ((suffix
= filename
+ len
-4), ".com") == 0
2872 || stricmp (suffix
, ".exe") == 0
2873 || stricmp (suffix
, ".bat") == 0)
2874 || (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2875 #endif /* not WINDOWSNT */
2876 #else /* not DOS_NT */
2877 #ifdef HAVE_EUIDACCESS
2878 return (euidaccess (filename
, 1) >= 0);
2880 /* Access isn't quite right because it uses the real uid
2881 and we really want to test with the effective uid.
2882 But Unix doesn't give us a right way to do it. */
2883 return (access (filename
, 1) >= 0);
2885 #endif /* not DOS_NT */
2888 /* Return nonzero if file FILENAME exists and can be written. */
2891 check_writable (filename
)
2896 if (stat (filename
, &st
) < 0)
2898 return (st
.st_mode
& S_IWRITE
|| (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2899 #else /* not MSDOS */
2900 #ifdef HAVE_EUIDACCESS
2901 return (euidaccess (filename
, 2) >= 0);
2903 /* Access isn't quite right because it uses the real uid
2904 and we really want to test with the effective uid.
2905 But Unix doesn't give us a right way to do it.
2906 Opening with O_WRONLY could work for an ordinary file,
2907 but would lose for directories. */
2908 return (access (filename
, 2) >= 0);
2910 #endif /* not MSDOS */
2913 DEFUN ("file-exists-p", Ffile_exists_p
, Sfile_exists_p
, 1, 1, 0,
2914 doc
: /* Return t if file FILENAME exists. (This does not mean you can read it.)
2915 See also `file-readable-p' and `file-attributes'. */)
2917 Lisp_Object filename
;
2919 Lisp_Object absname
;
2920 Lisp_Object handler
;
2921 struct stat statbuf
;
2923 CHECK_STRING (filename
);
2924 absname
= Fexpand_file_name (filename
, Qnil
);
2926 /* If the file name has special constructs in it,
2927 call the corresponding file handler. */
2928 handler
= Ffind_file_name_handler (absname
, Qfile_exists_p
);
2929 if (!NILP (handler
))
2930 return call2 (handler
, Qfile_exists_p
, absname
);
2932 absname
= ENCODE_FILE (absname
);
2934 return (stat (XSTRING (absname
)->data
, &statbuf
) >= 0) ? Qt
: Qnil
;
2937 DEFUN ("file-executable-p", Ffile_executable_p
, Sfile_executable_p
, 1, 1, 0,
2938 doc
: /* Return t if FILENAME can be executed by you.
2939 For a directory, this means you can access files in that directory. */)
2941 Lisp_Object filename
;
2943 Lisp_Object absname
;
2944 Lisp_Object handler
;
2946 CHECK_STRING (filename
);
2947 absname
= Fexpand_file_name (filename
, Qnil
);
2949 /* If the file name has special constructs in it,
2950 call the corresponding file handler. */
2951 handler
= Ffind_file_name_handler (absname
, Qfile_executable_p
);
2952 if (!NILP (handler
))
2953 return call2 (handler
, Qfile_executable_p
, absname
);
2955 absname
= ENCODE_FILE (absname
);
2957 return (check_executable (XSTRING (absname
)->data
) ? Qt
: Qnil
);
2960 DEFUN ("file-readable-p", Ffile_readable_p
, Sfile_readable_p
, 1, 1, 0,
2961 doc
: /* Return t if file FILENAME exists and you can read it.
2962 See also `file-exists-p' and `file-attributes'. */)
2964 Lisp_Object filename
;
2966 Lisp_Object absname
;
2967 Lisp_Object handler
;
2970 struct stat statbuf
;
2972 CHECK_STRING (filename
);
2973 absname
= Fexpand_file_name (filename
, Qnil
);
2975 /* If the file name has special constructs in it,
2976 call the corresponding file handler. */
2977 handler
= Ffind_file_name_handler (absname
, Qfile_readable_p
);
2978 if (!NILP (handler
))
2979 return call2 (handler
, Qfile_readable_p
, absname
);
2981 absname
= ENCODE_FILE (absname
);
2983 #if defined(DOS_NT) || defined(macintosh)
2984 /* Under MS-DOS, Windows, and Macintosh, open does not work for
2986 if (access (XSTRING (absname
)->data
, 0) == 0)
2989 #else /* not DOS_NT and not macintosh */
2991 #if defined (S_ISFIFO) && defined (O_NONBLOCK)
2992 /* Opening a fifo without O_NONBLOCK can wait.
2993 We don't want to wait. But we don't want to mess wth O_NONBLOCK
2994 except in the case of a fifo, on a system which handles it. */
2995 desc
= stat (XSTRING (absname
)->data
, &statbuf
);
2998 if (S_ISFIFO (statbuf
.st_mode
))
2999 flags
|= O_NONBLOCK
;
3001 desc
= emacs_open (XSTRING (absname
)->data
, flags
, 0);
3006 #endif /* not DOS_NT and not macintosh */
3009 /* Having this before file-symlink-p mysteriously caused it to be forgotten
3011 DEFUN ("file-writable-p", Ffile_writable_p
, Sfile_writable_p
, 1, 1, 0,
3012 doc
: /* Return t if file FILENAME can be written or created by you. */)
3014 Lisp_Object filename
;
3016 Lisp_Object absname
, dir
, encoded
;
3017 Lisp_Object handler
;
3018 struct stat statbuf
;
3020 CHECK_STRING (filename
);
3021 absname
= Fexpand_file_name (filename
, Qnil
);
3023 /* If the file name has special constructs in it,
3024 call the corresponding file handler. */
3025 handler
= Ffind_file_name_handler (absname
, Qfile_writable_p
);
3026 if (!NILP (handler
))
3027 return call2 (handler
, Qfile_writable_p
, absname
);
3029 encoded
= ENCODE_FILE (absname
);
3030 if (stat (XSTRING (encoded
)->data
, &statbuf
) >= 0)
3031 return (check_writable (XSTRING (encoded
)->data
)
3034 dir
= Ffile_name_directory (absname
);
3037 dir
= Fdirectory_file_name (dir
);
3041 dir
= Fdirectory_file_name (dir
);
3044 dir
= ENCODE_FILE (dir
);
3046 /* The read-only attribute of the parent directory doesn't affect
3047 whether a file or directory can be created within it. Some day we
3048 should check ACLs though, which do affect this. */
3049 if (stat (XSTRING (dir
)->data
, &statbuf
) < 0)
3051 return (statbuf
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
3053 return (check_writable (!NILP (dir
) ? (char *) XSTRING (dir
)->data
: "")
3058 DEFUN ("access-file", Faccess_file
, Saccess_file
, 2, 2, 0,
3059 doc
: /* Access file FILENAME, and get an error if that does not work.
3060 The second argument STRING is used in the error message.
3061 If there is no error, we return nil. */)
3063 Lisp_Object filename
, string
;
3065 Lisp_Object handler
, encoded_filename
, absname
;
3068 CHECK_STRING (filename
);
3069 absname
= Fexpand_file_name (filename
, Qnil
);
3071 CHECK_STRING (string
);
3073 /* If the file name has special constructs in it,
3074 call the corresponding file handler. */
3075 handler
= Ffind_file_name_handler (absname
, Qaccess_file
);
3076 if (!NILP (handler
))
3077 return call3 (handler
, Qaccess_file
, absname
, string
);
3079 encoded_filename
= ENCODE_FILE (absname
);
3081 fd
= emacs_open (XSTRING (encoded_filename
)->data
, O_RDONLY
, 0);
3083 report_file_error (XSTRING (string
)->data
, Fcons (filename
, Qnil
));
3089 DEFUN ("file-symlink-p", Ffile_symlink_p
, Sfile_symlink_p
, 1, 1, 0,
3090 doc
: /* Return non-nil if file FILENAME is the name of a symbolic link.
3091 The value is the name of the file to which it is linked.
3092 Otherwise returns nil. */)
3094 Lisp_Object filename
;
3101 Lisp_Object handler
;
3103 CHECK_STRING (filename
);
3104 filename
= Fexpand_file_name (filename
, Qnil
);
3106 /* If the file name has special constructs in it,
3107 call the corresponding file handler. */
3108 handler
= Ffind_file_name_handler (filename
, Qfile_symlink_p
);
3109 if (!NILP (handler
))
3110 return call2 (handler
, Qfile_symlink_p
, filename
);
3112 filename
= ENCODE_FILE (filename
);
3119 buf
= (char *) xrealloc (buf
, bufsize
);
3120 bzero (buf
, bufsize
);
3123 valsize
= readlink (XSTRING (filename
)->data
, buf
, bufsize
);
3127 /* HP-UX reports ERANGE if buffer is too small. */
3128 if (errno
== ERANGE
)
3138 while (valsize
>= bufsize
);
3140 val
= make_string (buf
, valsize
);
3141 if (buf
[0] == '/' && index (buf
, ':'))
3142 val
= concat2 (build_string ("/:"), val
);
3144 val
= DECODE_FILE (val
);
3146 #else /* not S_IFLNK */
3148 #endif /* not S_IFLNK */
3151 DEFUN ("file-directory-p", Ffile_directory_p
, Sfile_directory_p
, 1, 1, 0,
3152 doc
: /* Return t if FILENAME names an existing directory.
3153 Symbolic links to directories count as directories.
3154 See `file-symlink-p' to distinguish symlinks. */)
3156 Lisp_Object filename
;
3158 register Lisp_Object absname
;
3160 Lisp_Object handler
;
3162 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
3164 /* If the file name has special constructs in it,
3165 call the corresponding file handler. */
3166 handler
= Ffind_file_name_handler (absname
, Qfile_directory_p
);
3167 if (!NILP (handler
))
3168 return call2 (handler
, Qfile_directory_p
, absname
);
3170 absname
= ENCODE_FILE (absname
);
3172 if (stat (XSTRING (absname
)->data
, &st
) < 0)
3174 return (st
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
3177 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p
, Sfile_accessible_directory_p
, 1, 1, 0,
3178 doc
: /* Return t if file FILENAME names a directory you can open.
3179 For the value to be t, FILENAME must specify the name of a directory as a file,
3180 and the directory must allow you to open files in it. In order to use a
3181 directory as a buffer's current directory, this predicate must return true.
3182 A directory name spec may be given instead; then the value is t
3183 if the directory so specified exists and really is a readable and
3184 searchable directory. */)
3186 Lisp_Object filename
;
3188 Lisp_Object handler
;
3190 struct gcpro gcpro1
;
3192 /* If the file name has special constructs in it,
3193 call the corresponding file handler. */
3194 handler
= Ffind_file_name_handler (filename
, Qfile_accessible_directory_p
);
3195 if (!NILP (handler
))
3196 return call2 (handler
, Qfile_accessible_directory_p
, filename
);
3198 /* It's an unlikely combination, but yes we really do need to gcpro:
3199 Suppose that file-accessible-directory-p has no handler, but
3200 file-directory-p does have a handler; this handler causes a GC which
3201 relocates the string in `filename'; and finally file-directory-p
3202 returns non-nil. Then we would end up passing a garbaged string
3203 to file-executable-p. */
3205 tem
= (NILP (Ffile_directory_p (filename
))
3206 || NILP (Ffile_executable_p (filename
)));
3208 return tem
? Qnil
: Qt
;
3211 DEFUN ("file-regular-p", Ffile_regular_p
, Sfile_regular_p
, 1, 1, 0,
3212 doc
: /* Return t if file FILENAME is the name of a regular file.
3213 This is the sort of file that holds an ordinary stream of data bytes. */)
3215 Lisp_Object filename
;
3217 register Lisp_Object absname
;
3219 Lisp_Object handler
;
3221 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
3223 /* If the file name has special constructs in it,
3224 call the corresponding file handler. */
3225 handler
= Ffind_file_name_handler (absname
, Qfile_regular_p
);
3226 if (!NILP (handler
))
3227 return call2 (handler
, Qfile_regular_p
, absname
);
3229 absname
= ENCODE_FILE (absname
);
3234 Lisp_Object tem
= Vw32_get_true_file_attributes
;
3236 /* Tell stat to use expensive method to get accurate info. */
3237 Vw32_get_true_file_attributes
= Qt
;
3238 result
= stat (XSTRING (absname
)->data
, &st
);
3239 Vw32_get_true_file_attributes
= tem
;
3243 return (st
.st_mode
& S_IFMT
) == S_IFREG
? Qt
: Qnil
;
3246 if (stat (XSTRING (absname
)->data
, &st
) < 0)
3248 return (st
.st_mode
& S_IFMT
) == S_IFREG
? Qt
: Qnil
;
3252 DEFUN ("file-modes", Ffile_modes
, Sfile_modes
, 1, 1, 0,
3253 doc
: /* Return mode bits of file named FILENAME, as an integer. */)
3255 Lisp_Object filename
;
3257 Lisp_Object absname
;
3259 Lisp_Object handler
;
3261 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
3263 /* If the file name has special constructs in it,
3264 call the corresponding file handler. */
3265 handler
= Ffind_file_name_handler (absname
, Qfile_modes
);
3266 if (!NILP (handler
))
3267 return call2 (handler
, Qfile_modes
, absname
);
3269 absname
= ENCODE_FILE (absname
);
3271 if (stat (XSTRING (absname
)->data
, &st
) < 0)
3273 #if defined (MSDOS) && __DJGPP__ < 2
3274 if (check_executable (XSTRING (absname
)->data
))
3275 st
.st_mode
|= S_IEXEC
;
3276 #endif /* MSDOS && __DJGPP__ < 2 */
3278 return make_number (st
.st_mode
& 07777);
3281 DEFUN ("set-file-modes", Fset_file_modes
, Sset_file_modes
, 2, 2, 0,
3282 doc
: /* Set mode bits of file named FILENAME to MODE (an integer).
3283 Only the 12 low bits of MODE are used. */)
3285 Lisp_Object filename
, mode
;
3287 Lisp_Object absname
, encoded_absname
;
3288 Lisp_Object handler
;
3290 absname
= Fexpand_file_name (filename
, current_buffer
->directory
);
3291 CHECK_NUMBER (mode
);
3293 /* If the file name has special constructs in it,
3294 call the corresponding file handler. */
3295 handler
= Ffind_file_name_handler (absname
, Qset_file_modes
);
3296 if (!NILP (handler
))
3297 return call3 (handler
, Qset_file_modes
, absname
, mode
);
3299 encoded_absname
= ENCODE_FILE (absname
);
3301 if (chmod (XSTRING (encoded_absname
)->data
, XINT (mode
)) < 0)
3302 report_file_error ("Doing chmod", Fcons (absname
, Qnil
));
3307 DEFUN ("set-default-file-modes", Fset_default_file_modes
, Sset_default_file_modes
, 1, 1, 0,
3308 doc
: /* Set the file permission bits for newly created files.
3309 The argument MODE should be an integer; only the low 9 bits are used.
3310 This setting is inherited by subprocesses. */)
3314 CHECK_NUMBER (mode
);
3316 umask ((~ XINT (mode
)) & 0777);
3321 DEFUN ("default-file-modes", Fdefault_file_modes
, Sdefault_file_modes
, 0, 0, 0,
3322 doc
: /* Return the default file protection for created files.
3323 The value is an integer. */)
3329 realmask
= umask (0);
3332 XSETINT (value
, (~ realmask
) & 0777);
3342 DEFUN ("unix-sync", Funix_sync
, Sunix_sync
, 0, 0, "",
3343 doc
: /* Tell Unix to finish all pending disk updates. */)
3352 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p
, Sfile_newer_than_file_p
, 2, 2, 0,
3353 doc
: /* Return t if file FILE1 is newer than file FILE2.
3354 If FILE1 does not exist, the answer is nil;
3355 otherwise, if FILE2 does not exist, the answer is t. */)
3357 Lisp_Object file1
, file2
;
3359 Lisp_Object absname1
, absname2
;
3362 Lisp_Object handler
;
3363 struct gcpro gcpro1
, gcpro2
;
3365 CHECK_STRING (file1
);
3366 CHECK_STRING (file2
);
3369 GCPRO2 (absname1
, file2
);
3370 absname1
= expand_and_dir_to_file (file1
, current_buffer
->directory
);
3371 absname2
= expand_and_dir_to_file (file2
, current_buffer
->directory
);
3374 /* If the file name has special constructs in it,
3375 call the corresponding file handler. */
3376 handler
= Ffind_file_name_handler (absname1
, Qfile_newer_than_file_p
);
3378 handler
= Ffind_file_name_handler (absname2
, Qfile_newer_than_file_p
);
3379 if (!NILP (handler
))
3380 return call3 (handler
, Qfile_newer_than_file_p
, absname1
, absname2
);
3382 GCPRO2 (absname1
, absname2
);
3383 absname1
= ENCODE_FILE (absname1
);
3384 absname2
= ENCODE_FILE (absname2
);
3387 if (stat (XSTRING (absname1
)->data
, &st
) < 0)
3390 mtime1
= st
.st_mtime
;
3392 if (stat (XSTRING (absname2
)->data
, &st
) < 0)
3395 return (mtime1
> st
.st_mtime
) ? Qt
: Qnil
;
3399 Lisp_Object Qfind_buffer_file_type
;
3402 #ifndef READ_BUF_SIZE
3403 #define READ_BUF_SIZE (64 << 10)
3406 extern void adjust_markers_for_delete
P_ ((int, int, int, int));
3408 /* This function is called after Lisp functions to decide a coding
3409 system are called, or when they cause an error. Before they are
3410 called, the current buffer is set unibyte and it contains only a
3411 newly inserted text (thus the buffer was empty before the
3414 The functions may set markers, overlays, text properties, or even
3415 alter the buffer contents, change the current buffer.
3417 Here, we reset all those changes by:
3418 o set back the current buffer.
3419 o move all markers and overlays to BEG.
3420 o remove all text properties.
3421 o set back the buffer multibyteness. */
3424 decide_coding_unwind (unwind_data
)
3425 Lisp_Object unwind_data
;
3427 Lisp_Object multibyte
, undo_list
, buffer
;
3429 multibyte
= XCAR (unwind_data
);
3430 unwind_data
= XCDR (unwind_data
);
3431 undo_list
= XCAR (unwind_data
);
3432 buffer
= XCDR (unwind_data
);
3434 if (current_buffer
!= XBUFFER (buffer
))
3435 set_buffer_internal (XBUFFER (buffer
));
3436 adjust_markers_for_delete (BEG
, BEG_BYTE
, Z
, Z_BYTE
);
3437 adjust_overlays_for_delete (BEG
, Z
- BEG
);
3438 BUF_INTERVALS (current_buffer
) = 0;
3439 TEMP_SET_PT_BOTH (BEG
, BEG_BYTE
);
3441 /* Now we are safe to change the buffer's multibyteness directly. */
3442 current_buffer
->enable_multibyte_characters
= multibyte
;
3443 current_buffer
->undo_list
= undo_list
;
3449 /* Used to pass values from insert-file-contents to read_non_regular. */
3451 static int non_regular_fd
;
3452 static int non_regular_inserted
;
3453 static int non_regular_nbytes
;
3456 /* Read from a non-regular file.
3457 Read non_regular_trytry bytes max from non_regular_fd.
3458 Non_regular_inserted specifies where to put the read bytes.
3459 Value is the number of bytes read. */
3468 nbytes
= emacs_read (non_regular_fd
,
3469 BEG_ADDR
+ PT_BYTE
- 1 + non_regular_inserted
,
3470 non_regular_nbytes
);
3471 Fsignal (Qquit
, Qnil
);
3473 return make_number (nbytes
);
3477 /* Condition-case handler used when reading from non-regular files
3478 in insert-file-contents. */
3481 read_non_regular_quit ()
3487 DEFUN ("insert-file-contents", Finsert_file_contents
, Sinsert_file_contents
,
3489 doc
: /* Insert contents of file FILENAME after point.
3490 Returns list of absolute file name and number of bytes inserted.
3491 If second argument VISIT is non-nil, the buffer's visited filename
3492 and last save file modtime are set, and it is marked unmodified.
3493 If visiting and the file does not exist, visiting is completed
3494 before the error is signaled.
3495 The optional third and fourth arguments BEG and END
3496 specify what portion of the file to insert.
3497 These arguments count bytes in the file, not characters in the buffer.
3498 If VISIT is non-nil, BEG and END must be nil.
3500 If optional fifth argument REPLACE is non-nil,
3501 it means replace the current buffer contents (in the accessible portion)
3502 with the file contents. This is better than simply deleting and inserting
3503 the whole thing because (1) it preserves some marker positions
3504 and (2) it puts less data in the undo list.
3505 When REPLACE is non-nil, the value is the number of characters actually read,
3506 which is often less than the number of characters to be read.
3508 This does code conversion according to the value of
3509 `coding-system-for-read' or `file-coding-system-alist',
3510 and sets the variable `last-coding-system-used' to the coding system
3512 (filename
, visit
, beg
, end
, replace
)
3513 Lisp_Object filename
, visit
, beg
, end
, replace
;
3518 register int how_much
;
3519 register int unprocessed
;
3520 int count
= BINDING_STACK_SIZE ();
3521 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
3522 Lisp_Object handler
, val
, insval
, orig_filename
;
3525 int not_regular
= 0;
3526 unsigned char read_buf
[READ_BUF_SIZE
];
3527 struct coding_system coding
;
3528 unsigned char buffer
[1 << 14];
3529 int replace_handled
= 0;
3530 int set_coding_system
= 0;
3531 int coding_system_decided
= 0;
3534 if (current_buffer
->base_buffer
&& ! NILP (visit
))
3535 error ("Cannot do file visiting in an indirect buffer");
3537 if (!NILP (current_buffer
->read_only
))
3538 Fbarf_if_buffer_read_only ();
3542 orig_filename
= Qnil
;
3544 GCPRO4 (filename
, val
, p
, orig_filename
);
3546 CHECK_STRING (filename
);
3547 filename
= Fexpand_file_name (filename
, Qnil
);
3549 /* If the file name has special constructs in it,
3550 call the corresponding file handler. */
3551 handler
= Ffind_file_name_handler (filename
, Qinsert_file_contents
);
3552 if (!NILP (handler
))
3554 val
= call6 (handler
, Qinsert_file_contents
, filename
,
3555 visit
, beg
, end
, replace
);
3556 if (CONSP (val
) && CONSP (XCDR (val
)))
3557 inserted
= XINT (XCAR (XCDR (val
)));
3561 orig_filename
= filename
;
3562 filename
= ENCODE_FILE (filename
);
3568 Lisp_Object tem
= Vw32_get_true_file_attributes
;
3570 /* Tell stat to use expensive method to get accurate info. */
3571 Vw32_get_true_file_attributes
= Qt
;
3572 total
= stat (XSTRING (filename
)->data
, &st
);
3573 Vw32_get_true_file_attributes
= tem
;
3578 if (stat (XSTRING (filename
)->data
, &st
) < 0)
3580 if ((fd
= emacs_open (XSTRING (filename
)->data
, O_RDONLY
, 0)) < 0
3581 || fstat (fd
, &st
) < 0)
3582 #endif /* not APOLLO */
3583 #endif /* WINDOWSNT */
3585 if (fd
>= 0) emacs_close (fd
);
3588 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
3591 if (!NILP (Vcoding_system_for_read
))
3592 Fset (Qbuffer_file_coding_system
, Vcoding_system_for_read
);
3597 /* This code will need to be changed in order to work on named
3598 pipes, and it's probably just not worth it. So we should at
3599 least signal an error. */
3600 if (!S_ISREG (st
.st_mode
))
3607 if (! NILP (replace
) || ! NILP (beg
) || ! NILP (end
))
3608 Fsignal (Qfile_error
,
3609 Fcons (build_string ("not a regular file"),
3610 Fcons (orig_filename
, Qnil
)));
3615 if ((fd
= emacs_open (XSTRING (filename
)->data
, O_RDONLY
, 0)) < 0)
3618 /* Replacement should preserve point as it preserves markers. */
3619 if (!NILP (replace
))
3620 record_unwind_protect (restore_point_unwind
, Fpoint_marker ());
3622 record_unwind_protect (close_file_unwind
, make_number (fd
));
3624 /* Supposedly happens on VMS. */
3625 if (! not_regular
&& st
.st_size
< 0)
3626 error ("File size is negative");
3628 /* Prevent redisplay optimizations. */
3629 current_buffer
->clip_changed
= 1;
3633 if (!NILP (beg
) || !NILP (end
))
3634 error ("Attempt to visit less than an entire file");
3635 if (BEG
< Z
&& NILP (replace
))
3636 error ("Cannot do file visiting in a non-empty buffer");
3642 XSETFASTINT (beg
, 0);
3650 XSETINT (end
, st
.st_size
);
3652 /* Arithmetic overflow can occur if an Emacs integer cannot
3653 represent the file size, or if the calculations below
3654 overflow. The calculations below double the file size
3655 twice, so check that it can be multiplied by 4 safely. */
3656 if (XINT (end
) != st
.st_size
3657 || ((int) st
.st_size
* 4) / 4 != st
.st_size
)
3658 error ("Maximum buffer size exceeded");
3660 /* The file size returned from stat may be zero, but data
3661 may be readable nonetheless, for example when this is a
3662 file in the /proc filesystem. */
3663 if (st
.st_size
== 0)
3664 XSETINT (end
, READ_BUF_SIZE
);
3670 /* Decide the coding system to use for reading the file now
3671 because we can't use an optimized method for handling
3672 `coding:' tag if the current buffer is not empty. */
3676 if (!NILP (Vcoding_system_for_read
))
3677 val
= Vcoding_system_for_read
;
3678 else if (! NILP (replace
))
3679 /* In REPLACE mode, we can use the same coding system
3680 that was used to visit the file. */
3681 val
= current_buffer
->buffer_file_coding_system
;
3684 /* Don't try looking inside a file for a coding system
3685 specification if it is not seekable. */
3686 if (! not_regular
&& ! NILP (Vset_auto_coding_function
))
3688 /* Find a coding system specified in the heading two
3689 lines or in the tailing several lines of the file.
3690 We assume that the 1K-byte and 3K-byte for heading
3691 and tailing respectively are sufficient for this
3695 if (st
.st_size
<= (1024 * 4))
3696 nread
= emacs_read (fd
, read_buf
, 1024 * 4);
3699 nread
= emacs_read (fd
, read_buf
, 1024);
3702 if (lseek (fd
, st
.st_size
- (1024 * 3), 0) < 0)
3703 report_file_error ("Setting file position",
3704 Fcons (orig_filename
, Qnil
));
3705 nread
+= emacs_read (fd
, read_buf
+ nread
, 1024 * 3);
3710 error ("IO error reading %s: %s",
3711 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
3714 struct buffer
*prev
= current_buffer
;
3717 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
3719 /* The call to temp_output_buffer_setup binds
3721 count1
= specpdl_ptr
- specpdl
;
3722 temp_output_buffer_setup (" *code-converting-work*");
3724 set_buffer_internal (XBUFFER (Vstandard_output
));
3725 current_buffer
->enable_multibyte_characters
= Qnil
;
3726 insert_1_both (read_buf
, nread
, nread
, 0, 0, 0);
3727 TEMP_SET_PT_BOTH (BEG
, BEG_BYTE
);
3728 val
= call2 (Vset_auto_coding_function
,
3729 filename
, make_number (nread
));
3730 set_buffer_internal (prev
);
3732 /* Remove the binding for standard-output. */
3733 unbind_to (count1
, Qnil
);
3735 /* Discard the unwind protect for recovering the
3739 /* Rewind the file for the actual read done later. */
3740 if (lseek (fd
, 0, 0) < 0)
3741 report_file_error ("Setting file position",
3742 Fcons (orig_filename
, Qnil
));
3748 /* If we have not yet decided a coding system, check
3749 file-coding-system-alist. */
3750 Lisp_Object args
[6], coding_systems
;
3752 args
[0] = Qinsert_file_contents
, args
[1] = orig_filename
;
3753 args
[2] = visit
, args
[3] = beg
, args
[4] = end
, args
[5] = replace
;
3754 coding_systems
= Ffind_operation_coding_system (6, args
);
3755 if (CONSP (coding_systems
))
3756 val
= XCAR (coding_systems
);
3760 setup_coding_system (Fcheck_coding_system (val
), &coding
);
3761 /* Ensure we set Vlast_coding_system_used. */
3762 set_coding_system
= 1;
3764 if (NILP (current_buffer
->enable_multibyte_characters
)
3766 /* We must suppress all character code conversion except for
3767 end-of-line conversion. */
3768 setup_raw_text_coding_system (&coding
);
3770 coding
.src_multibyte
= 0;
3771 coding
.dst_multibyte
3772 = !NILP (current_buffer
->enable_multibyte_characters
);
3773 coding_system_decided
= 1;
3776 /* If requested, replace the accessible part of the buffer
3777 with the file contents. Avoid replacing text at the
3778 beginning or end of the buffer that matches the file contents;
3779 that preserves markers pointing to the unchanged parts.
3781 Here we implement this feature in an optimized way
3782 for the case where code conversion is NOT needed.
3783 The following if-statement handles the case of conversion
3784 in a less optimal way.
3786 If the code conversion is "automatic" then we try using this
3787 method and hope for the best.
3788 But if we discover the need for conversion, we give up on this method
3789 and let the following if-statement handle the replace job. */
3792 && !(coding
.common_flags
& CODING_REQUIRE_DECODING_MASK
))
3794 /* same_at_start and same_at_end count bytes,
3795 because file access counts bytes
3796 and BEG and END count bytes. */
3797 int same_at_start
= BEGV_BYTE
;
3798 int same_at_end
= ZV_BYTE
;
3800 /* There is still a possibility we will find the need to do code
3801 conversion. If that happens, we set this variable to 1 to
3802 give up on handling REPLACE in the optimized way. */
3803 int giveup_match_end
= 0;
3805 if (XINT (beg
) != 0)
3807 if (lseek (fd
, XINT (beg
), 0) < 0)
3808 report_file_error ("Setting file position",
3809 Fcons (orig_filename
, Qnil
));
3814 /* Count how many chars at the start of the file
3815 match the text at the beginning of the buffer. */
3820 nread
= emacs_read (fd
, buffer
, sizeof buffer
);
3822 error ("IO error reading %s: %s",
3823 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
3824 else if (nread
== 0)
3827 if (coding
.type
== coding_type_undecided
)
3828 detect_coding (&coding
, buffer
, nread
);
3829 if (coding
.common_flags
& CODING_REQUIRE_DECODING_MASK
)
3830 /* We found that the file should be decoded somehow.
3831 Let's give up here. */
3833 giveup_match_end
= 1;
3837 if (coding
.eol_type
== CODING_EOL_UNDECIDED
)
3838 detect_eol (&coding
, buffer
, nread
);
3839 if (coding
.eol_type
!= CODING_EOL_UNDECIDED
3840 && coding
.eol_type
!= CODING_EOL_LF
)
3841 /* We found that the format of eol should be decoded.
3842 Let's give up here. */
3844 giveup_match_end
= 1;
3849 while (bufpos
< nread
&& same_at_start
< ZV_BYTE
3850 && FETCH_BYTE (same_at_start
) == buffer
[bufpos
])
3851 same_at_start
++, bufpos
++;
3852 /* If we found a discrepancy, stop the scan.
3853 Otherwise loop around and scan the next bufferful. */
3854 if (bufpos
!= nread
)
3858 /* If the file matches the buffer completely,
3859 there's no need to replace anything. */
3860 if (same_at_start
- BEGV_BYTE
== XINT (end
))
3864 /* Truncate the buffer to the size of the file. */
3865 del_range_1 (same_at_start
, same_at_end
, 0, 0);
3870 /* Count how many chars at the end of the file
3871 match the text at the end of the buffer. But, if we have
3872 already found that decoding is necessary, don't waste time. */
3873 while (!giveup_match_end
)
3875 int total_read
, nread
, bufpos
, curpos
, trial
;
3877 /* At what file position are we now scanning? */
3878 curpos
= XINT (end
) - (ZV_BYTE
- same_at_end
);
3879 /* If the entire file matches the buffer tail, stop the scan. */
3882 /* How much can we scan in the next step? */
3883 trial
= min (curpos
, sizeof buffer
);
3884 if (lseek (fd
, curpos
- trial
, 0) < 0)
3885 report_file_error ("Setting file position",
3886 Fcons (orig_filename
, Qnil
));
3888 total_read
= nread
= 0;
3889 while (total_read
< trial
)
3891 nread
= emacs_read (fd
, buffer
+ total_read
, trial
- total_read
);
3893 error ("IO error reading %s: %s",
3894 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
3895 else if (nread
== 0)
3897 total_read
+= nread
;
3900 /* Scan this bufferful from the end, comparing with
3901 the Emacs buffer. */
3902 bufpos
= total_read
;
3904 /* Compare with same_at_start to avoid counting some buffer text
3905 as matching both at the file's beginning and at the end. */
3906 while (bufpos
> 0 && same_at_end
> same_at_start
3907 && FETCH_BYTE (same_at_end
- 1) == buffer
[bufpos
- 1])
3908 same_at_end
--, bufpos
--;
3910 /* If we found a discrepancy, stop the scan.
3911 Otherwise loop around and scan the preceding bufferful. */
3914 /* If this discrepancy is because of code conversion,
3915 we cannot use this method; giveup and try the other. */
3916 if (same_at_end
> same_at_start
3917 && FETCH_BYTE (same_at_end
- 1) >= 0200
3918 && ! NILP (current_buffer
->enable_multibyte_characters
)
3919 && (CODING_MAY_REQUIRE_DECODING (&coding
)))
3920 giveup_match_end
= 1;
3929 if (! giveup_match_end
)
3933 /* We win! We can handle REPLACE the optimized way. */
3935 /* Extend the start of non-matching text area to multibyte
3936 character boundary. */
3937 if (! NILP (current_buffer
->enable_multibyte_characters
))
3938 while (same_at_start
> BEGV_BYTE
3939 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_start
)))
3942 /* Extend the end of non-matching text area to multibyte
3943 character boundary. */
3944 if (! NILP (current_buffer
->enable_multibyte_characters
))
3945 while (same_at_end
< ZV_BYTE
3946 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_end
)))
3949 /* Don't try to reuse the same piece of text twice. */
3950 overlap
= (same_at_start
- BEGV_BYTE
3951 - (same_at_end
+ st
.st_size
- ZV
));
3953 same_at_end
+= overlap
;
3955 /* Arrange to read only the nonmatching middle part of the file. */
3956 XSETFASTINT (beg
, XINT (beg
) + (same_at_start
- BEGV_BYTE
));
3957 XSETFASTINT (end
, XINT (end
) - (ZV_BYTE
- same_at_end
));
3959 del_range_byte (same_at_start
, same_at_end
, 0);
3960 /* Insert from the file at the proper position. */
3961 temp
= BYTE_TO_CHAR (same_at_start
);
3962 SET_PT_BOTH (temp
, same_at_start
);
3964 /* If display currently starts at beginning of line,
3965 keep it that way. */
3966 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3967 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3969 replace_handled
= 1;
3973 /* If requested, replace the accessible part of the buffer
3974 with the file contents. Avoid replacing text at the
3975 beginning or end of the buffer that matches the file contents;
3976 that preserves markers pointing to the unchanged parts.
3978 Here we implement this feature for the case where code conversion
3979 is needed, in a simple way that needs a lot of memory.
3980 The preceding if-statement handles the case of no conversion
3981 in a more optimized way. */
3982 if (!NILP (replace
) && ! replace_handled
&& BEGV
< ZV
)
3984 int same_at_start
= BEGV_BYTE
;
3985 int same_at_end
= ZV_BYTE
;
3988 /* Make sure that the gap is large enough. */
3989 int bufsize
= 2 * st
.st_size
;
3990 unsigned char *conversion_buffer
= (unsigned char *) xmalloc (bufsize
);
3993 /* First read the whole file, performing code conversion into
3994 CONVERSION_BUFFER. */
3996 if (lseek (fd
, XINT (beg
), 0) < 0)
3998 xfree (conversion_buffer
);
3999 report_file_error ("Setting file position",
4000 Fcons (orig_filename
, Qnil
));
4003 total
= st
.st_size
; /* Total bytes in the file. */
4004 how_much
= 0; /* Bytes read from file so far. */
4005 inserted
= 0; /* Bytes put into CONVERSION_BUFFER so far. */
4006 unprocessed
= 0; /* Bytes not processed in previous loop. */
4008 while (how_much
< total
)
4010 /* try is reserved in some compilers (Microsoft C) */
4011 int trytry
= min (total
- how_much
, READ_BUF_SIZE
- unprocessed
);
4012 unsigned char *destination
= read_buf
+ unprocessed
;
4015 /* Allow quitting out of the actual I/O. */
4018 this = emacs_read (fd
, destination
, trytry
);
4021 if (this < 0 || this + unprocessed
== 0)
4029 if (CODING_MAY_REQUIRE_DECODING (&coding
))
4031 int require
, result
;
4033 this += unprocessed
;
4035 /* If we are using more space than estimated,
4036 make CONVERSION_BUFFER bigger. */
4037 require
= decoding_buffer_size (&coding
, this);
4038 if (inserted
+ require
+ 2 * (total
- how_much
) > bufsize
)
4040 bufsize
= inserted
+ require
+ 2 * (total
- how_much
);
4041 conversion_buffer
= (unsigned char *) xrealloc (conversion_buffer
, bufsize
);
4044 /* Convert this batch with results in CONVERSION_BUFFER. */
4045 if (how_much
>= total
) /* This is the last block. */
4046 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4047 if (coding
.composing
!= COMPOSITION_DISABLED
)
4048 coding_allocate_composition_data (&coding
, BEGV
);
4049 result
= decode_coding (&coding
, read_buf
,
4050 conversion_buffer
+ inserted
,
4051 this, bufsize
- inserted
);
4053 /* Save for next iteration whatever we didn't convert. */
4054 unprocessed
= this - coding
.consumed
;
4055 bcopy (read_buf
+ coding
.consumed
, read_buf
, unprocessed
);
4056 if (!NILP (current_buffer
->enable_multibyte_characters
))
4057 this = coding
.produced
;
4059 this = str_as_unibyte (conversion_buffer
+ inserted
,
4066 /* At this point, INSERTED is how many characters (i.e. bytes)
4067 are present in CONVERSION_BUFFER.
4068 HOW_MUCH should equal TOTAL,
4069 or should be <= 0 if we couldn't read the file. */
4073 xfree (conversion_buffer
);
4076 error ("IO error reading %s: %s",
4077 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
4078 else if (how_much
== -2)
4079 error ("maximum buffer size exceeded");
4082 /* Compare the beginning of the converted file
4083 with the buffer text. */
4086 while (bufpos
< inserted
&& same_at_start
< same_at_end
4087 && FETCH_BYTE (same_at_start
) == conversion_buffer
[bufpos
])
4088 same_at_start
++, bufpos
++;
4090 /* If the file matches the buffer completely,
4091 there's no need to replace anything. */
4093 if (bufpos
== inserted
)
4095 xfree (conversion_buffer
);
4098 /* Truncate the buffer to the size of the file. */
4099 del_range_byte (same_at_start
, same_at_end
, 0);
4104 /* Extend the start of non-matching text area to multibyte
4105 character boundary. */
4106 if (! NILP (current_buffer
->enable_multibyte_characters
))
4107 while (same_at_start
> BEGV_BYTE
4108 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_start
)))
4111 /* Scan this bufferful from the end, comparing with
4112 the Emacs buffer. */
4115 /* Compare with same_at_start to avoid counting some buffer text
4116 as matching both at the file's beginning and at the end. */
4117 while (bufpos
> 0 && same_at_end
> same_at_start
4118 && FETCH_BYTE (same_at_end
- 1) == conversion_buffer
[bufpos
- 1])
4119 same_at_end
--, bufpos
--;
4121 /* Extend the end of non-matching text area to multibyte
4122 character boundary. */
4123 if (! NILP (current_buffer
->enable_multibyte_characters
))
4124 while (same_at_end
< ZV_BYTE
4125 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_end
)))
4128 /* Don't try to reuse the same piece of text twice. */
4129 overlap
= same_at_start
- BEGV_BYTE
- (same_at_end
+ inserted
- ZV_BYTE
);
4131 same_at_end
+= overlap
;
4133 /* If display currently starts at beginning of line,
4134 keep it that way. */
4135 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
4136 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
4138 /* Replace the chars that we need to replace,
4139 and update INSERTED to equal the number of bytes
4140 we are taking from the file. */
4141 inserted
-= (Z_BYTE
- same_at_end
) + (same_at_start
- BEG_BYTE
);
4143 if (same_at_end
!= same_at_start
)
4145 del_range_byte (same_at_start
, same_at_end
, 0);
4147 same_at_start
= GPT_BYTE
;
4151 temp
= BYTE_TO_CHAR (same_at_start
);
4153 /* Insert from the file at the proper position. */
4154 SET_PT_BOTH (temp
, same_at_start
);
4155 insert_1 (conversion_buffer
+ same_at_start
- BEG_BYTE
, inserted
,
4157 if (coding
.cmp_data
&& coding
.cmp_data
->used
)
4158 coding_restore_composition (&coding
, Fcurrent_buffer ());
4159 coding_free_composition_data (&coding
);
4161 /* Set `inserted' to the number of inserted characters. */
4162 inserted
= PT
- temp
;
4164 xfree (conversion_buffer
);
4173 register Lisp_Object temp
;
4175 total
= XINT (end
) - XINT (beg
);
4177 /* Make sure point-max won't overflow after this insertion. */
4178 XSETINT (temp
, total
);
4179 if (total
!= XINT (temp
))
4180 error ("Maximum buffer size exceeded");
4183 /* For a special file, all we can do is guess. */
4184 total
= READ_BUF_SIZE
;
4186 if (NILP (visit
) && total
> 0)
4187 prepare_to_modify_buffer (PT
, PT
, NULL
);
4190 if (GAP_SIZE
< total
)
4191 make_gap (total
- GAP_SIZE
);
4193 if (XINT (beg
) != 0 || !NILP (replace
))
4195 if (lseek (fd
, XINT (beg
), 0) < 0)
4196 report_file_error ("Setting file position",
4197 Fcons (orig_filename
, Qnil
));
4200 /* In the following loop, HOW_MUCH contains the total bytes read so
4201 far for a regular file, and not changed for a special file. But,
4202 before exiting the loop, it is set to a negative value if I/O
4206 /* Total bytes inserted. */
4209 /* Here, we don't do code conversion in the loop. It is done by
4210 code_convert_region after all data are read into the buffer. */
4212 int gap_size
= GAP_SIZE
;
4214 while (how_much
< total
)
4216 /* try is reserved in some compilers (Microsoft C) */
4217 int trytry
= min (total
- how_much
, READ_BUF_SIZE
);
4224 /* Maybe make more room. */
4225 if (gap_size
< trytry
)
4227 make_gap (total
- gap_size
);
4228 gap_size
= GAP_SIZE
;
4231 /* Read from the file, capturing `quit'. When an
4232 error occurs, end the loop, and arrange for a quit
4233 to be signaled after decoding the text we read. */
4234 non_regular_fd
= fd
;
4235 non_regular_inserted
= inserted
;
4236 non_regular_nbytes
= trytry
;
4237 val
= internal_condition_case_1 (read_non_regular
, Qnil
, Qerror
,
4238 read_non_regular_quit
);
4249 /* Allow quitting out of the actual I/O. We don't make text
4250 part of the buffer until all the reading is done, so a C-g
4251 here doesn't do any harm. */
4254 this = emacs_read (fd
, BEG_ADDR
+ PT_BYTE
- 1 + inserted
, trytry
);
4266 /* For a regular file, where TOTAL is the real size,
4267 count HOW_MUCH to compare with it.
4268 For a special file, where TOTAL is just a buffer size,
4269 so don't bother counting in HOW_MUCH.
4270 (INSERTED is where we count the number of characters inserted.) */
4277 /* Make the text read part of the buffer. */
4278 GAP_SIZE
-= inserted
;
4280 GPT_BYTE
+= inserted
;
4282 ZV_BYTE
+= inserted
;
4287 /* Put an anchor to ensure multi-byte form ends at gap. */
4292 /* Discard the unwind protect for closing the file. */
4296 error ("IO error reading %s: %s",
4297 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
4301 if (! coding_system_decided
)
4303 /* The coding system is not yet decided. Decide it by an
4304 optimized method for handling `coding:' tag.
4306 Note that we can get here only if the buffer was empty
4307 before the insertion. */
4311 if (!NILP (Vcoding_system_for_read
))
4312 val
= Vcoding_system_for_read
;
4315 /* Since we are sure that the current buffer was empty
4316 before the insertion, we can toggle
4317 enable-multibyte-characters directly here without taking
4318 care of marker adjustment and byte combining problem. By
4319 this way, we can run Lisp program safely before decoding
4320 the inserted text. */
4321 Lisp_Object unwind_data
;
4322 int count
= specpdl_ptr
- specpdl
;
4324 unwind_data
= Fcons (current_buffer
->enable_multibyte_characters
,
4325 Fcons (current_buffer
->undo_list
,
4326 Fcurrent_buffer ()));
4327 current_buffer
->enable_multibyte_characters
= Qnil
;
4328 current_buffer
->undo_list
= Qt
;
4329 record_unwind_protect (decide_coding_unwind
, unwind_data
);
4331 if (inserted
> 0 && ! NILP (Vset_auto_coding_function
))
4333 val
= call2 (Vset_auto_coding_function
,
4334 filename
, make_number (inserted
));
4339 /* If the coding system is not yet decided, check
4340 file-coding-system-alist. */
4341 Lisp_Object args
[6], coding_systems
;
4343 args
[0] = Qinsert_file_contents
, args
[1] = orig_filename
;
4344 args
[2] = visit
, args
[3] = beg
, args
[4] = end
, args
[5] = Qnil
;
4345 coding_systems
= Ffind_operation_coding_system (6, args
);
4346 if (CONSP (coding_systems
))
4347 val
= XCAR (coding_systems
);
4350 unbind_to (count
, Qnil
);
4351 inserted
= Z_BYTE
- BEG_BYTE
;
4354 /* The following kludgy code is to avoid some compiler bug.
4356 setup_coding_system (val, &coding);
4359 struct coding_system temp_coding
;
4360 setup_coding_system (val
, &temp_coding
);
4361 bcopy (&temp_coding
, &coding
, sizeof coding
);
4363 /* Ensure we set Vlast_coding_system_used. */
4364 set_coding_system
= 1;
4366 if (NILP (current_buffer
->enable_multibyte_characters
)
4368 /* We must suppress all character code conversion except for
4369 end-of-line conversion. */
4370 setup_raw_text_coding_system (&coding
);
4371 coding
.src_multibyte
= 0;
4372 coding
.dst_multibyte
4373 = !NILP (current_buffer
->enable_multibyte_characters
);
4377 /* Can't do this if part of the buffer might be preserved. */
4379 && (coding
.type
== coding_type_no_conversion
4380 || coding
.type
== coding_type_raw_text
))
4382 /* Visiting a file with these coding system makes the buffer
4384 current_buffer
->enable_multibyte_characters
= Qnil
;
4385 coding
.dst_multibyte
= 0;
4388 if (inserted
> 0 || coding
.type
== coding_type_ccl
)
4390 if (CODING_MAY_REQUIRE_DECODING (&coding
))
4392 code_convert_region (PT
, PT_BYTE
, PT
+ inserted
, PT_BYTE
+ inserted
,
4394 inserted
= coding
.produced_char
;
4397 adjust_after_insert (PT
, PT_BYTE
, PT
+ inserted
, PT_BYTE
+ inserted
,
4402 /* Use the conversion type to determine buffer-file-type
4403 (find-buffer-file-type is now used to help determine the
4405 if ((coding
.eol_type
== CODING_EOL_UNDECIDED
4406 || coding
.eol_type
== CODING_EOL_LF
)
4407 && ! CODING_REQUIRE_DECODING (&coding
))
4408 current_buffer
->buffer_file_type
= Qt
;
4410 current_buffer
->buffer_file_type
= Qnil
;
4417 if (!EQ (current_buffer
->undo_list
, Qt
))
4418 current_buffer
->undo_list
= Qnil
;
4420 stat (XSTRING (filename
)->data
, &st
);
4425 current_buffer
->modtime
= st
.st_mtime
;
4426 current_buffer
->filename
= orig_filename
;
4429 SAVE_MODIFF
= MODIFF
;
4430 current_buffer
->auto_save_modified
= MODIFF
;
4431 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4432 #ifdef CLASH_DETECTION
4435 if (!NILP (current_buffer
->file_truename
))
4436 unlock_file (current_buffer
->file_truename
);
4437 unlock_file (filename
);
4439 #endif /* CLASH_DETECTION */
4441 Fsignal (Qfile_error
,
4442 Fcons (build_string ("not a regular file"),
4443 Fcons (orig_filename
, Qnil
)));
4446 /* Decode file format */
4449 int empty_undo_list_p
= 0;
4451 /* If we're anyway going to discard undo information, don't
4452 record it in the first place. The buffer's undo list at this
4453 point is either nil or t when visiting a file. */
4456 empty_undo_list_p
= NILP (current_buffer
->undo_list
);
4457 current_buffer
->undo_list
= Qt
;
4460 insval
= call3 (Qformat_decode
,
4461 Qnil
, make_number (inserted
), visit
);
4462 CHECK_NUMBER (insval
);
4463 inserted
= XFASTINT (insval
);
4466 current_buffer
->undo_list
= empty_undo_list_p
? Qnil
: Qt
;
4469 if (set_coding_system
)
4470 Vlast_coding_system_used
= coding
.symbol
;
4472 /* Call after-change hooks for the inserted text, aside from the case
4473 of normal visiting (not with REPLACE), which is done in a new buffer
4474 "before" the buffer is changed. */
4475 if (inserted
> 0 && total
> 0
4476 && (NILP (visit
) || !NILP (replace
)))
4478 signal_after_change (PT
, 0, inserted
);
4479 update_compositions (PT
, PT
, CHECK_BORDER
);
4482 p
= Vafter_insert_file_functions
;
4485 insval
= call1 (Fcar (p
), make_number (inserted
));
4488 CHECK_NUMBER (insval
);
4489 inserted
= XFASTINT (insval
);
4496 && current_buffer
->modtime
== -1)
4498 /* If visiting nonexistent file, return nil. */
4499 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
4503 Fsignal (Qquit
, Qnil
);
4505 /* ??? Retval needs to be dealt with in all cases consistently. */
4507 val
= Fcons (orig_filename
,
4508 Fcons (make_number (inserted
),
4511 RETURN_UNGCPRO (unbind_to (count
, val
));
4514 static Lisp_Object build_annotations
P_ ((Lisp_Object
, Lisp_Object
));
4515 static Lisp_Object build_annotations_2
P_ ((Lisp_Object
, Lisp_Object
,
4516 Lisp_Object
, Lisp_Object
));
4518 /* If build_annotations switched buffers, switch back to BUF.
4519 Kill the temporary buffer that was selected in the meantime.
4521 Since this kill only the last temporary buffer, some buffers remain
4522 not killed if build_annotations switched buffers more than once.
4526 build_annotations_unwind (buf
)
4531 if (XBUFFER (buf
) == current_buffer
)
4533 tembuf
= Fcurrent_buffer ();
4535 Fkill_buffer (tembuf
);
4539 /* Decide the coding-system to encode the data with. */
4542 choose_write_coding_system (start
, end
, filename
,
4543 append
, visit
, lockname
, coding
)
4544 Lisp_Object start
, end
, filename
, append
, visit
, lockname
;
4545 struct coding_system
*coding
;
4551 else if (!NILP (Vcoding_system_for_write
))
4552 val
= Vcoding_system_for_write
;
4555 /* If the variable `buffer-file-coding-system' is set locally,
4556 it means that the file was read with some kind of code
4557 conversion or the variable is explicitly set by users. We
4558 had better write it out with the same coding system even if
4559 `enable-multibyte-characters' is nil.
4561 If it is not set locally, we anyway have to convert EOL
4562 format if the default value of `buffer-file-coding-system'
4563 tells that it is not Unix-like (LF only) format. */
4564 int using_default_coding
= 0;
4565 int force_raw_text
= 0;
4567 val
= current_buffer
->buffer_file_coding_system
;
4569 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4572 if (NILP (current_buffer
->enable_multibyte_characters
))
4578 /* Check file-coding-system-alist. */
4579 Lisp_Object args
[7], coding_systems
;
4581 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4582 args
[3] = filename
; args
[4] = append
; args
[5] = visit
;
4584 coding_systems
= Ffind_operation_coding_system (7, args
);
4585 if (CONSP (coding_systems
) && !NILP (XCDR (coding_systems
)))
4586 val
= XCDR (coding_systems
);
4590 && !NILP (current_buffer
->buffer_file_coding_system
))
4592 /* If we still have not decided a coding system, use the
4593 default value of buffer-file-coding-system. */
4594 val
= current_buffer
->buffer_file_coding_system
;
4595 using_default_coding
= 1;
4599 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4600 /* Confirm that VAL can surely encode the current region. */
4601 val
= call3 (Vselect_safe_coding_system_function
, start
, end
, val
);
4603 setup_coding_system (Fcheck_coding_system (val
), coding
);
4604 if (coding
->eol_type
== CODING_EOL_UNDECIDED
4605 && !using_default_coding
)
4607 if (! EQ (default_buffer_file_coding
.symbol
,
4608 buffer_defaults
.buffer_file_coding_system
))
4609 setup_coding_system (buffer_defaults
.buffer_file_coding_system
,
4610 &default_buffer_file_coding
);
4611 if (default_buffer_file_coding
.eol_type
!= CODING_EOL_UNDECIDED
)
4613 Lisp_Object subsidiaries
;
4615 coding
->eol_type
= default_buffer_file_coding
.eol_type
;
4616 subsidiaries
= Fget (coding
->symbol
, Qeol_type
);
4617 if (VECTORP (subsidiaries
)
4618 && XVECTOR (subsidiaries
)->size
== 3)
4620 = XVECTOR (subsidiaries
)->contents
[coding
->eol_type
];
4625 setup_raw_text_coding_system (coding
);
4626 goto done_setup_coding
;
4629 setup_coding_system (Fcheck_coding_system (val
), coding
);
4632 if (!STRINGP (start
) && !NILP (current_buffer
->selective_display
))
4633 coding
->mode
|= CODING_MODE_SELECTIVE_DISPLAY
;
4636 DEFUN ("write-region", Fwrite_region
, Swrite_region
, 3, 7,
4637 "r\nFWrite region to file: \ni\ni\ni\np",
4638 doc
: /* Write current region into specified file.
4639 When called from a program, takes three arguments:
4640 START, END and FILENAME. START and END are buffer positions.
4641 Optional fourth argument APPEND if non-nil means
4642 append to existing file contents (if any). If it is an integer,
4643 seek to that offset in the file before writing.
4644 Optional fifth argument VISIT if t means
4645 set the last-save-file-modtime of buffer to this file's modtime
4646 and mark buffer not modified.
4647 If VISIT is a string, it is a second file name;
4648 the output goes to FILENAME, but the buffer is marked as visiting VISIT.
4649 VISIT is also the file name to lock and unlock for clash detection.
4650 If VISIT is neither t nor nil nor a string,
4651 that means do not print the \"Wrote file\" message.
4652 The optional sixth arg LOCKNAME, if non-nil, specifies the name to
4653 use for locking and unlocking, overriding FILENAME and VISIT.
4654 The optional seventh arg MUSTBENEW, if non-nil, insists on a check
4655 for an existing file with the same name. If MUSTBENEW is `excl',
4656 that means to get an error if the file already exists; never overwrite.
4657 If MUSTBENEW is neither nil nor `excl', that means ask for
4658 confirmation before overwriting, but do go ahead and overwrite the file
4659 if the user confirms.
4660 Kludgy feature: if START is a string, then that string is written
4661 to the file, instead of any buffer contents, and END is ignored.
4663 This does code conversion according to the value of
4664 `coding-system-for-write', `buffer-file-coding-system', or
4665 `file-coding-system-alist', and sets the variable
4666 `last-coding-system-used' to the coding system actually used. */)
4667 (start
, end
, filename
, append
, visit
, lockname
, mustbenew
)
4668 Lisp_Object start
, end
, filename
, append
, visit
, lockname
, mustbenew
;
4676 int count
= specpdl_ptr
- specpdl
;
4679 unsigned char *fname
= 0; /* If non-0, original filename (must rename) */
4681 Lisp_Object handler
;
4682 Lisp_Object visit_file
;
4683 Lisp_Object annotations
= Qnil
;
4684 Lisp_Object encoded_filename
;
4685 int visiting
= (EQ (visit
, Qt
) || STRINGP (visit
));
4686 int quietly
= !NILP (visit
);
4687 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
4688 struct buffer
*given_buffer
;
4690 int buffer_file_type
= O_BINARY
;
4692 struct coding_system coding
;
4694 if (current_buffer
->base_buffer
&& visiting
)
4695 error ("Cannot do file visiting in an indirect buffer");
4697 if (!NILP (start
) && !STRINGP (start
))
4698 validate_region (&start
, &end
);
4700 GCPRO4 (start
, filename
, visit
, lockname
);
4702 /* Decide the coding-system to encode the data with. */
4703 choose_write_coding_system (start
, end
, filename
,
4704 append
, visit
, lockname
, &coding
);
4705 Vlast_coding_system_used
= coding
.symbol
;
4707 filename
= Fexpand_file_name (filename
, Qnil
);
4709 if (!NILP (mustbenew
) && !EQ (mustbenew
, Qexcl
))
4710 barf_or_query_if_file_exists (filename
, "overwrite", 1, 0, 1);
4712 if (STRINGP (visit
))
4713 visit_file
= Fexpand_file_name (visit
, Qnil
);
4715 visit_file
= filename
;
4718 if (NILP (lockname
))
4719 lockname
= visit_file
;
4721 GCPRO5 (start
, filename
, annotations
, visit_file
, lockname
);
4723 /* If the file name has special constructs in it,
4724 call the corresponding file handler. */
4725 handler
= Ffind_file_name_handler (filename
, Qwrite_region
);
4726 /* If FILENAME has no handler, see if VISIT has one. */
4727 if (NILP (handler
) && STRINGP (visit
))
4728 handler
= Ffind_file_name_handler (visit
, Qwrite_region
);
4730 if (!NILP (handler
))
4733 val
= call6 (handler
, Qwrite_region
, start
, end
,
4734 filename
, append
, visit
);
4738 SAVE_MODIFF
= MODIFF
;
4739 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4740 current_buffer
->filename
= visit_file
;
4746 /* Special kludge to simplify auto-saving. */
4749 XSETFASTINT (start
, BEG
);
4750 XSETFASTINT (end
, Z
);
4753 record_unwind_protect (build_annotations_unwind
, Fcurrent_buffer ());
4754 count1
= specpdl_ptr
- specpdl
;
4756 given_buffer
= current_buffer
;
4757 annotations
= build_annotations (start
, end
);
4758 if (current_buffer
!= given_buffer
)
4760 XSETFASTINT (start
, BEGV
);
4761 XSETFASTINT (end
, ZV
);
4766 GCPRO5 (start
, filename
, annotations
, visit_file
, lockname
);
4768 given_buffer
= current_buffer
;
4769 annotations
= build_annotations_2 (start
, end
,
4770 coding
.pre_write_conversion
, annotations
);
4771 if (current_buffer
!= given_buffer
)
4773 XSETFASTINT (start
, BEGV
);
4774 XSETFASTINT (end
, ZV
);
4777 #ifdef CLASH_DETECTION
4780 #if 0 /* This causes trouble for GNUS. */
4781 /* If we've locked this file for some other buffer,
4782 query before proceeding. */
4783 if (!visiting
&& EQ (Ffile_locked_p (lockname
), Qt
))
4784 call2 (intern ("ask-user-about-lock"), filename
, Vuser_login_name
);
4787 lock_file (lockname
);
4789 #endif /* CLASH_DETECTION */
4791 encoded_filename
= ENCODE_FILE (filename
);
4793 fn
= XSTRING (encoded_filename
)->data
;
4797 desc
= emacs_open (fn
, O_WRONLY
| buffer_file_type
, 0);
4798 #else /* not DOS_NT */
4799 desc
= emacs_open (fn
, O_WRONLY
, 0);
4800 #endif /* not DOS_NT */
4802 if (desc
< 0 && (NILP (append
) || errno
== ENOENT
))
4804 if (auto_saving
) /* Overwrite any previous version of autosave file */
4806 vms_truncate (fn
); /* if fn exists, truncate to zero length */
4807 desc
= emacs_open (fn
, O_RDWR
, 0);
4809 desc
= creat_copy_attrs (STRINGP (current_buffer
->filename
)
4810 ? XSTRING (current_buffer
->filename
)->data
: 0,
4813 else /* Write to temporary name and rename if no errors */
4815 Lisp_Object temp_name
;
4816 temp_name
= Ffile_name_directory (filename
);
4818 if (!NILP (temp_name
))
4820 temp_name
= Fmake_temp_name (concat2 (temp_name
,
4821 build_string ("$$SAVE$$")));
4822 fname
= XSTRING (filename
)->data
;
4823 fn
= XSTRING (temp_name
)->data
;
4824 desc
= creat_copy_attrs (fname
, fn
);
4827 /* If we can't open the temporary file, try creating a new
4828 version of the original file. VMS "creat" creates a
4829 new version rather than truncating an existing file. */
4832 desc
= creat (fn
, 0666);
4833 #if 0 /* This can clobber an existing file and fail to replace it,
4834 if the user runs out of space. */
4837 /* We can't make a new version;
4838 try to truncate and rewrite existing version if any. */
4840 desc
= emacs_open (fn
, O_RDWR
, 0);
4846 desc
= creat (fn
, 0666);
4850 desc
= emacs_open (fn
,
4851 O_WRONLY
| O_CREAT
| buffer_file_type
4852 | (EQ (mustbenew
, Qexcl
) ? O_EXCL
: O_TRUNC
),
4853 S_IREAD
| S_IWRITE
);
4854 #else /* not DOS_NT */
4855 desc
= emacs_open (fn
, O_WRONLY
| O_TRUNC
| O_CREAT
4856 | (EQ (mustbenew
, Qexcl
) ? O_EXCL
: 0),
4857 auto_saving
? auto_save_mode_bits
: 0666);
4858 #endif /* not DOS_NT */
4859 #endif /* not VMS */
4863 #ifdef CLASH_DETECTION
4865 if (!auto_saving
) unlock_file (lockname
);
4867 #endif /* CLASH_DETECTION */
4869 report_file_error ("Opening output file", Fcons (filename
, Qnil
));
4872 record_unwind_protect (close_file_unwind
, make_number (desc
));
4874 if (!NILP (append
) && !NILP (Ffile_regular_p (filename
)))
4878 if (NUMBERP (append
))
4879 ret
= lseek (desc
, XINT (append
), 1);
4881 ret
= lseek (desc
, 0, 2);
4884 #ifdef CLASH_DETECTION
4885 if (!auto_saving
) unlock_file (lockname
);
4886 #endif /* CLASH_DETECTION */
4888 report_file_error ("Lseek error", Fcons (filename
, Qnil
));
4896 * Kludge Warning: The VMS C RTL likes to insert carriage returns
4897 * if we do writes that don't end with a carriage return. Furthermore
4898 * it cannot handle writes of more then 16K. The modified
4899 * version of "sys_write" in SYSDEP.C (see comment there) copes with
4900 * this EXCEPT for the last record (iff it doesn't end with a carriage
4901 * return). This implies that if your buffer doesn't end with a carriage
4902 * return, you get one free... tough. However it also means that if
4903 * we make two calls to sys_write (a la the following code) you can
4904 * get one at the gap as well. The easiest way to fix this (honest)
4905 * is to move the gap to the next newline (or the end of the buffer).
4910 if (GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4911 move_gap (find_next_newline (GPT
, 1));
4913 /* Whether VMS or not, we must move the gap to the next of newline
4914 when we must put designation sequences at beginning of line. */
4915 if (INTEGERP (start
)
4916 && coding
.type
== coding_type_iso2022
4917 && coding
.flags
& CODING_FLAG_ISO_DESIGNATE_AT_BOL
4918 && GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4920 int opoint
= PT
, opoint_byte
= PT_BYTE
;
4921 scan_newline (PT
, PT_BYTE
, ZV
, ZV_BYTE
, 1, 0);
4922 move_gap_both (PT
, PT_BYTE
);
4923 SET_PT_BOTH (opoint
, opoint_byte
);
4930 if (STRINGP (start
))
4932 failure
= 0 > a_write (desc
, start
, 0, XSTRING (start
)->size
,
4933 &annotations
, &coding
);
4936 else if (XINT (start
) != XINT (end
))
4938 tem
= CHAR_TO_BYTE (XINT (start
));
4940 if (XINT (start
) < GPT
)
4942 failure
= 0 > a_write (desc
, Qnil
, XINT (start
),
4943 min (GPT
, XINT (end
)) - XINT (start
),
4944 &annotations
, &coding
);
4948 if (XINT (end
) > GPT
&& !failure
)
4950 tem
= max (XINT (start
), GPT
);
4951 failure
= 0 > a_write (desc
, Qnil
, tem
, XINT (end
) - tem
,
4952 &annotations
, &coding
);
4958 /* If file was empty, still need to write the annotations */
4959 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4960 failure
= 0 > a_write (desc
, Qnil
, XINT (end
), 0, &annotations
, &coding
);
4964 if (CODING_REQUIRE_FLUSHING (&coding
)
4965 && !(coding
.mode
& CODING_MODE_LAST_BLOCK
)
4968 /* We have to flush out a data. */
4969 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4970 failure
= 0 > e_write (desc
, Qnil
, 0, 0, &coding
);
4977 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
4978 Disk full in NFS may be reported here. */
4979 /* mib says that closing the file will try to write as fast as NFS can do
4980 it, and that means the fsync here is not crucial for autosave files. */
4981 if (!auto_saving
&& fsync (desc
) < 0)
4983 /* If fsync fails with EINTR, don't treat that as serious. */
4985 failure
= 1, save_errno
= errno
;
4989 /* Spurious "file has changed on disk" warnings have been
4990 observed on Suns as well.
4991 It seems that `close' can change the modtime, under nfs.
4993 (This has supposedly been fixed in Sunos 4,
4994 but who knows about all the other machines with NFS?) */
4997 /* On VMS and APOLLO, must do the stat after the close
4998 since closing changes the modtime. */
5001 /* Recall that #if defined does not work on VMS. */
5008 /* NFS can report a write failure now. */
5009 if (emacs_close (desc
) < 0)
5010 failure
= 1, save_errno
= errno
;
5013 /* If we wrote to a temporary name and had no errors, rename to real name. */
5017 failure
= (rename (fn
, fname
) != 0), save_errno
= errno
;
5025 /* Discard the unwind protect for close_file_unwind. */
5026 specpdl_ptr
= specpdl
+ count1
;
5027 /* Restore the original current buffer. */
5028 visit_file
= unbind_to (count
, visit_file
);
5030 #ifdef CLASH_DETECTION
5032 unlock_file (lockname
);
5033 #endif /* CLASH_DETECTION */
5035 /* Do this before reporting IO error
5036 to avoid a "file has changed on disk" warning on
5037 next attempt to save. */
5039 current_buffer
->modtime
= st
.st_mtime
;
5042 error ("IO error writing %s: %s", XSTRING (filename
)->data
,
5043 emacs_strerror (save_errno
));
5047 SAVE_MODIFF
= MODIFF
;
5048 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
5049 current_buffer
->filename
= visit_file
;
5050 update_mode_lines
++;
5056 message_with_string ("Wrote %s", visit_file
, 1);
5061 Lisp_Object
merge ();
5063 DEFUN ("car-less-than-car", Fcar_less_than_car
, Scar_less_than_car
, 2, 2, 0,
5064 doc
: /* Return t if (car A) is numerically less than (car B). */)
5068 return Flss (Fcar (a
), Fcar (b
));
5071 /* Build the complete list of annotations appropriate for writing out
5072 the text between START and END, by calling all the functions in
5073 write-region-annotate-functions and merging the lists they return.
5074 If one of these functions switches to a different buffer, we assume
5075 that buffer contains altered text. Therefore, the caller must
5076 make sure to restore the current buffer in all cases,
5077 as save-excursion would do. */
5080 build_annotations (start
, end
)
5081 Lisp_Object start
, end
;
5083 Lisp_Object annotations
;
5085 struct gcpro gcpro1
, gcpro2
;
5086 Lisp_Object original_buffer
;
5089 XSETBUFFER (original_buffer
, current_buffer
);
5092 p
= Vwrite_region_annotate_functions
;
5093 GCPRO2 (annotations
, p
);
5096 struct buffer
*given_buffer
= current_buffer
;
5097 Vwrite_region_annotations_so_far
= annotations
;
5098 res
= call2 (Fcar (p
), start
, end
);
5099 /* If the function makes a different buffer current,
5100 assume that means this buffer contains altered text to be output.
5101 Reset START and END from the buffer bounds
5102 and discard all previous annotations because they should have
5103 been dealt with by this function. */
5104 if (current_buffer
!= given_buffer
)
5106 XSETFASTINT (start
, BEGV
);
5107 XSETFASTINT (end
, ZV
);
5110 Flength (res
); /* Check basic validity of return value */
5111 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
5115 /* Now do the same for annotation functions implied by the file-format */
5116 if (auto_saving
&& (!EQ (Vauto_save_file_format
, Qt
)))
5117 p
= Vauto_save_file_format
;
5119 p
= current_buffer
->file_format
;
5120 for (i
= 0; !NILP (p
); p
= Fcdr (p
), ++i
)
5122 struct buffer
*given_buffer
= current_buffer
;
5124 Vwrite_region_annotations_so_far
= annotations
;
5126 /* Value is either a list of annotations or nil if the function
5127 has written annotations to a temporary buffer, which is now
5129 res
= call5 (Qformat_annotate_function
, Fcar (p
), start
, end
,
5130 original_buffer
, make_number (i
));
5131 if (current_buffer
!= given_buffer
)
5133 XSETFASTINT (start
, BEGV
);
5134 XSETFASTINT (end
, ZV
);
5139 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
5147 build_annotations_2 (start
, end
, pre_write_conversion
, annotations
)
5148 Lisp_Object start
, end
, pre_write_conversion
, annotations
;
5150 struct gcpro gcpro1
;
5153 GCPRO1 (annotations
);
5154 /* At last, do the same for the function PRE_WRITE_CONVERSION
5155 implied by the current coding-system. */
5156 if (!NILP (pre_write_conversion
))
5158 struct buffer
*given_buffer
= current_buffer
;
5159 Vwrite_region_annotations_so_far
= annotations
;
5160 res
= call2 (pre_write_conversion
, start
, end
);
5162 annotations
= (current_buffer
!= given_buffer
5164 : merge (annotations
, res
, Qcar_less_than_car
));
5171 /* Write to descriptor DESC the NCHARS chars starting at POS of STRING.
5172 If STRING is nil, POS is the character position in the current buffer.
5173 Intersperse with them the annotations from *ANNOT
5174 which fall within the range of POS to POS + NCHARS,
5175 each at its appropriate position.
5177 We modify *ANNOT by discarding elements as we use them up.
5179 The return value is negative in case of system call failure. */
5182 a_write (desc
, string
, pos
, nchars
, annot
, coding
)
5185 register int nchars
;
5188 struct coding_system
*coding
;
5192 int lastpos
= pos
+ nchars
;
5194 while (NILP (*annot
) || CONSP (*annot
))
5196 tem
= Fcar_safe (Fcar (*annot
));
5199 nextpos
= XFASTINT (tem
);
5201 /* If there are no more annotations in this range,
5202 output the rest of the range all at once. */
5203 if (! (nextpos
>= pos
&& nextpos
<= lastpos
))
5204 return e_write (desc
, string
, pos
, lastpos
, coding
);
5206 /* Output buffer text up to the next annotation's position. */
5209 if (0 > e_write (desc
, string
, pos
, nextpos
, coding
))
5213 /* Output the annotation. */
5214 tem
= Fcdr (Fcar (*annot
));
5217 if (0 > e_write (desc
, tem
, 0, XSTRING (tem
)->size
, coding
))
5220 *annot
= Fcdr (*annot
);
5225 #ifndef WRITE_BUF_SIZE
5226 #define WRITE_BUF_SIZE (16 * 1024)
5229 /* Write text in the range START and END into descriptor DESC,
5230 encoding them with coding system CODING. If STRING is nil, START
5231 and END are character positions of the current buffer, else they
5232 are indexes to the string STRING. */
5235 e_write (desc
, string
, start
, end
, coding
)
5239 struct coding_system
*coding
;
5241 register char *addr
;
5242 register int nbytes
;
5243 char buf
[WRITE_BUF_SIZE
];
5247 coding
->composing
= COMPOSITION_DISABLED
;
5248 if (coding
->composing
!= COMPOSITION_DISABLED
)
5249 coding_save_composition (coding
, start
, end
, string
);
5251 if (STRINGP (string
))
5253 addr
= XSTRING (string
)->data
;
5254 nbytes
= STRING_BYTES (XSTRING (string
));
5255 coding
->src_multibyte
= STRING_MULTIBYTE (string
);
5257 else if (start
< end
)
5259 /* It is assured that the gap is not in the range START and END-1. */
5260 addr
= CHAR_POS_ADDR (start
);
5261 nbytes
= CHAR_TO_BYTE (end
) - CHAR_TO_BYTE (start
);
5262 coding
->src_multibyte
5263 = !NILP (current_buffer
->enable_multibyte_characters
);
5269 coding
->src_multibyte
= 1;
5272 /* We used to have a code for handling selective display here. But,
5273 now it is handled within encode_coding. */
5278 result
= encode_coding (coding
, addr
, buf
, nbytes
, WRITE_BUF_SIZE
);
5279 if (coding
->produced
> 0)
5281 coding
->produced
-= emacs_write (desc
, buf
, coding
->produced
);
5282 if (coding
->produced
)
5288 nbytes
-= coding
->consumed
;
5289 addr
+= coding
->consumed
;
5290 if (result
== CODING_FINISH_INSUFFICIENT_SRC
5293 /* The source text ends by an incomplete multibyte form.
5294 There's no way other than write it out as is. */
5295 nbytes
-= emacs_write (desc
, addr
, nbytes
);
5304 start
+= coding
->consumed_char
;
5305 if (coding
->cmp_data
)
5306 coding_adjust_composition_offset (coding
, start
);
5309 if (coding
->cmp_data
)
5310 coding_free_composition_data (coding
);
5315 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime
,
5316 Sverify_visited_file_modtime
, 1, 1, 0,
5317 doc
: /* Return t if last mod time of BUF's visited file matches what BUF records.
5318 This means that the file has not been changed since it was visited or saved. */)
5324 Lisp_Object handler
;
5325 Lisp_Object filename
;
5330 if (!STRINGP (b
->filename
)) return Qt
;
5331 if (b
->modtime
== 0) return Qt
;
5333 /* If the file name has special constructs in it,
5334 call the corresponding file handler. */
5335 handler
= Ffind_file_name_handler (b
->filename
,
5336 Qverify_visited_file_modtime
);
5337 if (!NILP (handler
))
5338 return call2 (handler
, Qverify_visited_file_modtime
, buf
);
5340 filename
= ENCODE_FILE (b
->filename
);
5342 if (stat (XSTRING (filename
)->data
, &st
) < 0)
5344 /* If the file doesn't exist now and didn't exist before,
5345 we say that it isn't modified, provided the error is a tame one. */
5346 if (errno
== ENOENT
|| errno
== EACCES
|| errno
== ENOTDIR
)
5351 if (st
.st_mtime
== b
->modtime
5352 /* If both are positive, accept them if they are off by one second. */
5353 || (st
.st_mtime
> 0 && b
->modtime
> 0
5354 && (st
.st_mtime
== b
->modtime
+ 1
5355 || st
.st_mtime
== b
->modtime
- 1)))
5360 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime
,
5361 Sclear_visited_file_modtime
, 0, 0, 0,
5362 doc
: /* Clear out records of last mod time of visited file.
5363 Next attempt to save will certainly not complain of a discrepancy. */)
5366 current_buffer
->modtime
= 0;
5370 DEFUN ("visited-file-modtime", Fvisited_file_modtime
,
5371 Svisited_file_modtime
, 0, 0, 0,
5372 doc
: /* Return the current buffer's recorded visited file modification time.
5373 The value is a list of the form (HIGH . LOW), like the time values
5374 that `file-attributes' returns. */)
5377 return long_to_cons ((unsigned long) current_buffer
->modtime
);
5380 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime
,
5381 Sset_visited_file_modtime
, 0, 1, 0,
5382 doc
: /* Update buffer's recorded modification time from the visited file's time.
5383 Useful if the buffer was not read from the file normally
5384 or if the file itself has been changed for some known benign reason.
5385 An argument specifies the modification time value to use
5386 \(instead of that of the visited file), in the form of a list
5387 \(HIGH . LOW) or (HIGH LOW). */)
5389 Lisp_Object time_list
;
5391 if (!NILP (time_list
))
5392 current_buffer
->modtime
= cons_to_long (time_list
);
5395 register Lisp_Object filename
;
5397 Lisp_Object handler
;
5399 filename
= Fexpand_file_name (current_buffer
->filename
, Qnil
);
5401 /* If the file name has special constructs in it,
5402 call the corresponding file handler. */
5403 handler
= Ffind_file_name_handler (filename
, Qset_visited_file_modtime
);
5404 if (!NILP (handler
))
5405 /* The handler can find the file name the same way we did. */
5406 return call2 (handler
, Qset_visited_file_modtime
, Qnil
);
5408 filename
= ENCODE_FILE (filename
);
5410 if (stat (XSTRING (filename
)->data
, &st
) >= 0)
5411 current_buffer
->modtime
= st
.st_mtime
;
5418 auto_save_error (error
)
5421 Lisp_Object args
[3], msg
;
5423 struct gcpro gcpro1
;
5427 args
[0] = build_string ("Auto-saving %s: %s");
5428 args
[1] = current_buffer
->name
;
5429 args
[2] = Ferror_message_string (error
);
5430 msg
= Fformat (3, args
);
5432 nbytes
= STRING_BYTES (XSTRING (msg
));
5434 for (i
= 0; i
< 3; ++i
)
5437 message2 (XSTRING (msg
)->data
, nbytes
, STRING_MULTIBYTE (msg
));
5439 message2_nolog (XSTRING (msg
)->data
, nbytes
, STRING_MULTIBYTE (msg
));
5440 Fsleep_for (make_number (1), Qnil
);
5452 /* Get visited file's mode to become the auto save file's mode. */
5453 if (! NILP (current_buffer
->filename
)
5454 && stat (XSTRING (current_buffer
->filename
)->data
, &st
) >= 0)
5455 /* But make sure we can overwrite it later! */
5456 auto_save_mode_bits
= st
.st_mode
| 0600;
5458 auto_save_mode_bits
= 0666;
5461 Fwrite_region (Qnil
, Qnil
,
5462 current_buffer
->auto_save_file_name
,
5463 Qnil
, Qlambda
, Qnil
, Qnil
);
5467 do_auto_save_unwind (stream
) /* used as unwind-protect function */
5472 fclose ((FILE *) (XFASTINT (XCAR (stream
)) << 16
5473 | XFASTINT (XCDR (stream
))));
5479 do_auto_save_unwind_1 (value
) /* used as unwind-protect function */
5482 minibuffer_auto_raise
= XINT (value
);
5486 DEFUN ("do-auto-save", Fdo_auto_save
, Sdo_auto_save
, 0, 2, "",
5487 doc
: /* Auto-save all buffers that need it.
5488 This is all buffers that have auto-saving enabled
5489 and are changed since last auto-saved.
5490 Auto-saving writes the buffer into a file
5491 so that your editing is not lost if the system crashes.
5492 This file is not the file you visited; that changes only when you save.
5493 Normally we run the normal hook `auto-save-hook' before saving.
5495 A non-nil NO-MESSAGE argument means do not print any message if successful.
5496 A non-nil CURRENT-ONLY argument means save only current buffer. */)
5497 (no_message
, current_only
)
5498 Lisp_Object no_message
, current_only
;
5500 struct buffer
*old
= current_buffer
, *b
;
5501 Lisp_Object tail
, buf
;
5503 int do_handled_files
;
5506 Lisp_Object lispstream
;
5507 int count
= specpdl_ptr
- specpdl
;
5508 int orig_minibuffer_auto_raise
= minibuffer_auto_raise
;
5509 int message_p
= push_message ();
5511 /* Ordinarily don't quit within this function,
5512 but don't make it impossible to quit (in case we get hung in I/O). */
5516 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
5517 point to non-strings reached from Vbuffer_alist. */
5522 if (!NILP (Vrun_hooks
))
5523 call1 (Vrun_hooks
, intern ("auto-save-hook"));
5525 if (STRINGP (Vauto_save_list_file_name
))
5527 Lisp_Object listfile
;
5529 listfile
= Fexpand_file_name (Vauto_save_list_file_name
, Qnil
);
5531 /* Don't try to create the directory when shutting down Emacs,
5532 because creating the directory might signal an error, and
5533 that would leave Emacs in a strange state. */
5534 if (!NILP (Vrun_hooks
))
5537 dir
= Ffile_name_directory (listfile
);
5538 if (NILP (Ffile_directory_p (dir
)))
5539 call2 (Qmake_directory
, dir
, Qt
);
5542 stream
= fopen (XSTRING (listfile
)->data
, "w");
5545 /* Arrange to close that file whether or not we get an error.
5546 Also reset auto_saving to 0. */
5547 lispstream
= Fcons (Qnil
, Qnil
);
5548 XSETCARFASTINT (lispstream
, (EMACS_UINT
)stream
>> 16);
5549 XSETCDRFASTINT (lispstream
, (EMACS_UINT
)stream
& 0xffff);
5560 record_unwind_protect (do_auto_save_unwind
, lispstream
);
5561 record_unwind_protect (do_auto_save_unwind_1
,
5562 make_number (minibuffer_auto_raise
));
5563 minibuffer_auto_raise
= 0;
5566 /* First, save all files which don't have handlers. If Emacs is
5567 crashing, the handlers may tweak what is causing Emacs to crash
5568 in the first place, and it would be a shame if Emacs failed to
5569 autosave perfectly ordinary files because it couldn't handle some
5571 for (do_handled_files
= 0; do_handled_files
< 2; do_handled_files
++)
5572 for (tail
= Vbuffer_alist
; GC_CONSP (tail
); tail
= XCDR (tail
))
5574 buf
= XCDR (XCAR (tail
));
5577 /* Record all the buffers that have auto save mode
5578 in the special file that lists them. For each of these buffers,
5579 Record visited name (if any) and auto save name. */
5580 if (STRINGP (b
->auto_save_file_name
)
5581 && stream
!= NULL
&& do_handled_files
== 0)
5583 if (!NILP (b
->filename
))
5585 fwrite (XSTRING (b
->filename
)->data
, 1,
5586 STRING_BYTES (XSTRING (b
->filename
)), stream
);
5588 putc ('\n', stream
);
5589 fwrite (XSTRING (b
->auto_save_file_name
)->data
, 1,
5590 STRING_BYTES (XSTRING (b
->auto_save_file_name
)), stream
);
5591 putc ('\n', stream
);
5594 if (!NILP (current_only
)
5595 && b
!= current_buffer
)
5598 /* Don't auto-save indirect buffers.
5599 The base buffer takes care of it. */
5603 /* Check for auto save enabled
5604 and file changed since last auto save
5605 and file changed since last real save. */
5606 if (STRINGP (b
->auto_save_file_name
)
5607 && BUF_SAVE_MODIFF (b
) < BUF_MODIFF (b
)
5608 && b
->auto_save_modified
< BUF_MODIFF (b
)
5609 /* -1 means we've turned off autosaving for a while--see below. */
5610 && XINT (b
->save_length
) >= 0
5611 && (do_handled_files
5612 || NILP (Ffind_file_name_handler (b
->auto_save_file_name
,
5615 EMACS_TIME before_time
, after_time
;
5617 EMACS_GET_TIME (before_time
);
5619 /* If we had a failure, don't try again for 20 minutes. */
5620 if (b
->auto_save_failure_time
>= 0
5621 && EMACS_SECS (before_time
) - b
->auto_save_failure_time
< 1200)
5624 if ((XFASTINT (b
->save_length
) * 10
5625 > (BUF_Z (b
) - BUF_BEG (b
)) * 13)
5626 /* A short file is likely to change a large fraction;
5627 spare the user annoying messages. */
5628 && XFASTINT (b
->save_length
) > 5000
5629 /* These messages are frequent and annoying for `*mail*'. */
5630 && !EQ (b
->filename
, Qnil
)
5631 && NILP (no_message
))
5633 /* It has shrunk too much; turn off auto-saving here. */
5634 minibuffer_auto_raise
= orig_minibuffer_auto_raise
;
5635 message_with_string ("Buffer %s has shrunk a lot; auto save turned off there",
5637 minibuffer_auto_raise
= 0;
5638 /* Turn off auto-saving until there's a real save,
5639 and prevent any more warnings. */
5640 XSETINT (b
->save_length
, -1);
5641 Fsleep_for (make_number (1), Qnil
);
5644 set_buffer_internal (b
);
5645 if (!auto_saved
&& NILP (no_message
))
5646 message1 ("Auto-saving...");
5647 internal_condition_case (auto_save_1
, Qt
, auto_save_error
);
5649 b
->auto_save_modified
= BUF_MODIFF (b
);
5650 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
5651 set_buffer_internal (old
);
5653 EMACS_GET_TIME (after_time
);
5655 /* If auto-save took more than 60 seconds,
5656 assume it was an NFS failure that got a timeout. */
5657 if (EMACS_SECS (after_time
) - EMACS_SECS (before_time
) > 60)
5658 b
->auto_save_failure_time
= EMACS_SECS (after_time
);
5662 /* Prevent another auto save till enough input events come in. */
5663 record_auto_save ();
5665 if (auto_saved
&& NILP (no_message
))
5669 sit_for (1, 0, 0, 0, 0);
5673 message1 ("Auto-saving...done");
5678 unbind_to (count
, Qnil
);
5682 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved
,
5683 Sset_buffer_auto_saved
, 0, 0, 0,
5684 doc
: /* Mark current buffer as auto-saved with its current text.
5685 No auto-save file will be written until the buffer changes again. */)
5688 current_buffer
->auto_save_modified
= MODIFF
;
5689 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
5690 current_buffer
->auto_save_failure_time
= -1;
5694 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure
,
5695 Sclear_buffer_auto_save_failure
, 0, 0, 0,
5696 doc
: /* Clear any record of a recent auto-save failure in the current buffer. */)
5699 current_buffer
->auto_save_failure_time
= -1;
5703 DEFUN ("recent-auto-save-p", Frecent_auto_save_p
, Srecent_auto_save_p
,
5705 doc
: /* Return t if buffer has been auto-saved since last read in or saved. */)
5708 return (SAVE_MODIFF
< current_buffer
->auto_save_modified
) ? Qt
: Qnil
;
5711 /* Reading and completing file names */
5712 extern Lisp_Object
Ffile_name_completion (), Ffile_name_all_completions ();
5714 /* In the string VAL, change each $ to $$ and return the result. */
5717 double_dollars (val
)
5720 register unsigned char *old
, *new;
5724 osize
= STRING_BYTES (XSTRING (val
));
5726 /* Count the number of $ characters. */
5727 for (n
= osize
, count
= 0, old
= XSTRING (val
)->data
; n
> 0; n
--)
5728 if (*old
++ == '$') count
++;
5731 old
= XSTRING (val
)->data
;
5732 val
= make_uninit_multibyte_string (XSTRING (val
)->size
+ count
,
5734 new = XSTRING (val
)->data
;
5735 for (n
= osize
; n
> 0; n
--)
5748 DEFUN ("read-file-name-internal", Fread_file_name_internal
, Sread_file_name_internal
,
5750 doc
: /* Internal subroutine for read-file-name. Do not call this. */)
5751 (string
, dir
, action
)
5752 Lisp_Object string
, dir
, action
;
5753 /* action is nil for complete, t for return list of completions,
5754 lambda for verify final value */
5756 Lisp_Object name
, specdir
, realdir
, val
, orig_string
;
5758 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
5760 CHECK_STRING (string
);
5767 /* No need to protect ACTION--we only compare it with t and nil. */
5768 GCPRO5 (string
, realdir
, name
, specdir
, orig_string
);
5770 if (XSTRING (string
)->size
== 0)
5772 if (EQ (action
, Qlambda
))
5780 orig_string
= string
;
5781 string
= Fsubstitute_in_file_name (string
);
5782 changed
= NILP (Fstring_equal (string
, orig_string
));
5783 name
= Ffile_name_nondirectory (string
);
5784 val
= Ffile_name_directory (string
);
5786 realdir
= Fexpand_file_name (val
, realdir
);
5791 specdir
= Ffile_name_directory (string
);
5792 val
= Ffile_name_completion (name
, realdir
);
5797 return double_dollars (string
);
5801 if (!NILP (specdir
))
5802 val
= concat2 (specdir
, val
);
5804 return double_dollars (val
);
5807 #endif /* not VMS */
5811 if (EQ (action
, Qt
))
5812 return Ffile_name_all_completions (name
, realdir
);
5813 /* Only other case actually used is ACTION = lambda */
5815 /* Supposedly this helps commands such as `cd' that read directory names,
5816 but can someone explain how it helps them? -- RMS */
5817 if (XSTRING (name
)->size
== 0)
5820 return Ffile_exists_p (string
);
5823 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
5824 doc
: /* Read file name, prompting with PROMPT and completing in directory DIR.
5825 Value is not expanded---you must call `expand-file-name' yourself.
5826 Default name to DEFAULT-FILENAME if user enters a null string.
5827 (If DEFAULT-FILENAME is omitted, the visited file name is used,
5828 except that if INITIAL is specified, that combined with DIR is used.)
5829 Fourth arg MUSTMATCH non-nil means require existing file's name.
5830 Non-nil and non-t means also require confirmation after completion.
5831 Fifth arg INITIAL specifies text to start with.
5832 DIR defaults to current buffer's directory default.
5834 If this command was invoked with the mouse, use a file dialog box if
5835 `use-dialog-box' is non-nil, and the window system or X toolkit in use
5836 provides a file dialog box. */)
5837 (prompt
, dir
, default_filename
, mustmatch
, initial
)
5838 Lisp_Object prompt
, dir
, default_filename
, mustmatch
, initial
;
5840 Lisp_Object val
, insdef
, tem
;
5841 struct gcpro gcpro1
, gcpro2
;
5842 register char *homedir
;
5843 int replace_in_history
= 0;
5844 int add_to_history
= 0;
5848 dir
= current_buffer
->directory
;
5849 if (NILP (default_filename
))
5851 if (! NILP (initial
))
5852 default_filename
= Fexpand_file_name (initial
, dir
);
5854 default_filename
= current_buffer
->filename
;
5857 /* If dir starts with user's homedir, change that to ~. */
5858 homedir
= (char *) egetenv ("HOME");
5860 /* homedir can be NULL in temacs, since Vprocess_environment is not
5861 yet set up. We shouldn't crash in that case. */
5864 homedir
= strcpy (alloca (strlen (homedir
) + 1), homedir
);
5865 CORRECT_DIR_SEPS (homedir
);
5870 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
5871 && IS_DIRECTORY_SEP (XSTRING (dir
)->data
[strlen (homedir
)]))
5873 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
5874 STRING_BYTES (XSTRING (dir
)) - strlen (homedir
) + 1);
5875 XSTRING (dir
)->data
[0] = '~';
5877 /* Likewise for default_filename. */
5879 && STRINGP (default_filename
)
5880 && !strncmp (homedir
, XSTRING (default_filename
)->data
, strlen (homedir
))
5881 && IS_DIRECTORY_SEP (XSTRING (default_filename
)->data
[strlen (homedir
)]))
5884 = make_string (XSTRING (default_filename
)->data
+ strlen (homedir
) - 1,
5885 STRING_BYTES (XSTRING (default_filename
)) - strlen (homedir
) + 1);
5886 XSTRING (default_filename
)->data
[0] = '~';
5888 if (!NILP (default_filename
))
5890 CHECK_STRING (default_filename
);
5891 default_filename
= double_dollars (default_filename
);
5894 if (insert_default_directory
&& STRINGP (dir
))
5897 if (!NILP (initial
))
5899 Lisp_Object args
[2], pos
;
5903 insdef
= Fconcat (2, args
);
5904 pos
= make_number (XSTRING (double_dollars (dir
))->size
);
5905 insdef
= Fcons (double_dollars (insdef
), pos
);
5908 insdef
= double_dollars (insdef
);
5910 else if (STRINGP (initial
))
5911 insdef
= Fcons (double_dollars (initial
), make_number (0));
5915 count
= specpdl_ptr
- specpdl
;
5917 specbind (intern ("completion-ignore-case"), Qt
);
5920 specbind (intern ("minibuffer-completing-file-name"), Qt
);
5922 GCPRO2 (insdef
, default_filename
);
5924 #if defined (USE_MOTIF) || defined (HAVE_NTGUI)
5925 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
5929 /* If DIR contains a file name, split it. */
5931 file
= Ffile_name_nondirectory (dir
);
5932 if (XSTRING (file
)->size
&& NILP (default_filename
))
5934 default_filename
= file
;
5935 dir
= Ffile_name_directory (dir
);
5937 if (!NILP(default_filename
))
5938 default_filename
= Fexpand_file_name (default_filename
, dir
);
5939 val
= Fx_file_dialog (prompt
, dir
, default_filename
, mustmatch
);
5944 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
5945 dir
, mustmatch
, insdef
,
5946 Qfile_name_history
, default_filename
, Qnil
);
5948 tem
= Fsymbol_value (Qfile_name_history
);
5949 if (CONSP (tem
) && EQ (XCAR (tem
), val
))
5950 replace_in_history
= 1;
5952 /* If Fcompleting_read returned the inserted default string itself
5953 (rather than a new string with the same contents),
5954 it has to mean that the user typed RET with the minibuffer empty.
5955 In that case, we really want to return ""
5956 so that commands such as set-visited-file-name can distinguish. */
5957 if (EQ (val
, default_filename
))
5959 /* In this case, Fcompleting_read has not added an element
5960 to the history. Maybe we should. */
5961 if (! replace_in_history
)
5964 val
= build_string ("");
5967 unbind_to (count
, Qnil
);
5970 error ("No file name specified");
5972 tem
= Fstring_equal (val
, CONSP (insdef
) ? XCAR (insdef
) : insdef
);
5974 if (!NILP (tem
) && !NILP (default_filename
))
5975 val
= default_filename
;
5976 else if (XSTRING (val
)->size
== 0 && NILP (insdef
))
5978 if (!NILP (default_filename
))
5979 val
= default_filename
;
5981 error ("No default file name");
5983 val
= Fsubstitute_in_file_name (val
);
5985 if (replace_in_history
)
5986 /* Replace what Fcompleting_read added to the history
5987 with what we will actually return. */
5988 XSETCAR (Fsymbol_value (Qfile_name_history
), double_dollars (val
));
5989 else if (add_to_history
)
5991 /* Add the value to the history--but not if it matches
5992 the last value already there. */
5993 Lisp_Object val1
= double_dollars (val
);
5994 tem
= Fsymbol_value (Qfile_name_history
);
5995 if (! CONSP (tem
) || NILP (Fequal (XCAR (tem
), val1
)))
5996 Fset (Qfile_name_history
,
6007 /* Must be set before any path manipulation is performed. */
6008 XSETFASTINT (Vdirectory_sep_char
, '/');
6015 Qexpand_file_name
= intern ("expand-file-name");
6016 Qsubstitute_in_file_name
= intern ("substitute-in-file-name");
6017 Qdirectory_file_name
= intern ("directory-file-name");
6018 Qfile_name_directory
= intern ("file-name-directory");
6019 Qfile_name_nondirectory
= intern ("file-name-nondirectory");
6020 Qunhandled_file_name_directory
= intern ("unhandled-file-name-directory");
6021 Qfile_name_as_directory
= intern ("file-name-as-directory");
6022 Qcopy_file
= intern ("copy-file");
6023 Qmake_directory_internal
= intern ("make-directory-internal");
6024 Qmake_directory
= intern ("make-directory");
6025 Qdelete_directory
= intern ("delete-directory");
6026 Qdelete_file
= intern ("delete-file");
6027 Qrename_file
= intern ("rename-file");
6028 Qadd_name_to_file
= intern ("add-name-to-file");
6029 Qmake_symbolic_link
= intern ("make-symbolic-link");
6030 Qfile_exists_p
= intern ("file-exists-p");
6031 Qfile_executable_p
= intern ("file-executable-p");
6032 Qfile_readable_p
= intern ("file-readable-p");
6033 Qfile_writable_p
= intern ("file-writable-p");
6034 Qfile_symlink_p
= intern ("file-symlink-p");
6035 Qaccess_file
= intern ("access-file");
6036 Qfile_directory_p
= intern ("file-directory-p");
6037 Qfile_regular_p
= intern ("file-regular-p");
6038 Qfile_accessible_directory_p
= intern ("file-accessible-directory-p");
6039 Qfile_modes
= intern ("file-modes");
6040 Qset_file_modes
= intern ("set-file-modes");
6041 Qfile_newer_than_file_p
= intern ("file-newer-than-file-p");
6042 Qinsert_file_contents
= intern ("insert-file-contents");
6043 Qwrite_region
= intern ("write-region");
6044 Qverify_visited_file_modtime
= intern ("verify-visited-file-modtime");
6045 Qset_visited_file_modtime
= intern ("set-visited-file-modtime");
6047 staticpro (&Qexpand_file_name
);
6048 staticpro (&Qsubstitute_in_file_name
);
6049 staticpro (&Qdirectory_file_name
);
6050 staticpro (&Qfile_name_directory
);
6051 staticpro (&Qfile_name_nondirectory
);
6052 staticpro (&Qunhandled_file_name_directory
);
6053 staticpro (&Qfile_name_as_directory
);
6054 staticpro (&Qcopy_file
);
6055 staticpro (&Qmake_directory_internal
);
6056 staticpro (&Qmake_directory
);
6057 staticpro (&Qdelete_directory
);
6058 staticpro (&Qdelete_file
);
6059 staticpro (&Qrename_file
);
6060 staticpro (&Qadd_name_to_file
);
6061 staticpro (&Qmake_symbolic_link
);
6062 staticpro (&Qfile_exists_p
);
6063 staticpro (&Qfile_executable_p
);
6064 staticpro (&Qfile_readable_p
);
6065 staticpro (&Qfile_writable_p
);
6066 staticpro (&Qaccess_file
);
6067 staticpro (&Qfile_symlink_p
);
6068 staticpro (&Qfile_directory_p
);
6069 staticpro (&Qfile_regular_p
);
6070 staticpro (&Qfile_accessible_directory_p
);
6071 staticpro (&Qfile_modes
);
6072 staticpro (&Qset_file_modes
);
6073 staticpro (&Qfile_newer_than_file_p
);
6074 staticpro (&Qinsert_file_contents
);
6075 staticpro (&Qwrite_region
);
6076 staticpro (&Qverify_visited_file_modtime
);
6077 staticpro (&Qset_visited_file_modtime
);
6079 Qfile_name_history
= intern ("file-name-history");
6080 Fset (Qfile_name_history
, Qnil
);
6081 staticpro (&Qfile_name_history
);
6083 Qfile_error
= intern ("file-error");
6084 staticpro (&Qfile_error
);
6085 Qfile_already_exists
= intern ("file-already-exists");
6086 staticpro (&Qfile_already_exists
);
6087 Qfile_date_error
= intern ("file-date-error");
6088 staticpro (&Qfile_date_error
);
6089 Qexcl
= intern ("excl");
6093 Qfind_buffer_file_type
= intern ("find-buffer-file-type");
6094 staticpro (&Qfind_buffer_file_type
);
6097 DEFVAR_LISP ("file-name-coding-system", &Vfile_name_coding_system
,
6098 doc
: /* *Coding system for encoding file names.
6099 If it is nil, default-file-name-coding-system (which see) is used. */);
6100 Vfile_name_coding_system
= Qnil
;
6102 DEFVAR_LISP ("default-file-name-coding-system",
6103 &Vdefault_file_name_coding_system
,
6104 doc
: /* Default coding system for encoding file names.
6105 This variable is used only when file-name-coding-system is nil.
6107 This variable is set/changed by the command set-language-environment.
6108 User should not set this variable manually,
6109 instead use file-name-coding-system to get a constant encoding
6110 of file names regardless of the current language environment. */);
6111 Vdefault_file_name_coding_system
= Qnil
;
6113 DEFVAR_LISP ("auto-save-file-format", &Vauto_save_file_format
,
6114 doc
: /* *Format in which to write auto-save files.
6115 Should be a list of symbols naming formats that are defined in `format-alist'.
6116 If it is t, which is the default, auto-save files are written in the
6117 same format as a regular save would use. */);
6118 Vauto_save_file_format
= Qt
;
6120 Qformat_decode
= intern ("format-decode");
6121 staticpro (&Qformat_decode
);
6122 Qformat_annotate_function
= intern ("format-annotate-function");
6123 staticpro (&Qformat_annotate_function
);
6125 Qcar_less_than_car
= intern ("car-less-than-car");
6126 staticpro (&Qcar_less_than_car
);
6128 Fput (Qfile_error
, Qerror_conditions
,
6129 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
)));
6130 Fput (Qfile_error
, Qerror_message
,
6131 build_string ("File error"));
6133 Fput (Qfile_already_exists
, Qerror_conditions
,
6134 Fcons (Qfile_already_exists
,
6135 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
6136 Fput (Qfile_already_exists
, Qerror_message
,
6137 build_string ("File already exists"));
6139 Fput (Qfile_date_error
, Qerror_conditions
,
6140 Fcons (Qfile_date_error
,
6141 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
6142 Fput (Qfile_date_error
, Qerror_message
,
6143 build_string ("Cannot set file date"));
6145 DEFVAR_BOOL ("insert-default-directory", &insert_default_directory
,
6146 doc
: /* *Non-nil means when reading a filename start with default dir in minibuffer. */);
6147 insert_default_directory
= 1;
6149 DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm
,
6150 doc
: /* *Non-nil means write new files with record format `stmlf'.
6151 nil means use format `var'. This variable is meaningful only on VMS. */);
6152 vms_stmlf_recfm
= 0;
6154 DEFVAR_LISP ("directory-sep-char", &Vdirectory_sep_char
,
6155 doc
: /* Directory separator character for built-in functions that return file names.
6156 The value should be either ?/ or ?\\ (any other value is treated as ?\\).
6157 This variable affects the built-in functions only on Windows,
6158 on other platforms, it is initialized so that Lisp code can find out
6159 what the normal separator is.
6161 WARNING: This variable is deprecated and will be removed in the near
6162 future. DO NOT USE IT. */);
6164 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist
,
6165 doc
: /* *Alist of elements (REGEXP . HANDLER) for file names handled specially.
6166 If a file name matches REGEXP, then all I/O on that file is done by calling
6169 The first argument given to HANDLER is the name of the I/O primitive
6170 to be handled; the remaining arguments are the arguments that were
6171 passed to that primitive. For example, if you do
6172 (file-exists-p FILENAME)
6173 and FILENAME is handled by HANDLER, then HANDLER is called like this:
6174 (funcall HANDLER 'file-exists-p FILENAME)
6175 The function `find-file-name-handler' checks this list for a handler
6176 for its argument. */);
6177 Vfile_name_handler_alist
= Qnil
;
6179 DEFVAR_LISP ("set-auto-coding-function",
6180 &Vset_auto_coding_function
,
6181 doc
: /* If non-nil, a function to call to decide a coding system of file.
6182 Two arguments are passed to this function: the file name
6183 and the length of a file contents following the point.
6184 This function should return a coding system to decode the file contents.
6185 It should check the file name against `auto-coding-alist'.
6186 If no coding system is decided, it should check a coding system
6187 specified in the heading lines with the format:
6188 -*- ... coding: CODING-SYSTEM; ... -*-
6189 or local variable spec of the tailing lines with `coding:' tag. */);
6190 Vset_auto_coding_function
= Qnil
;
6192 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions
,
6193 doc
: /* A list of functions to be called at the end of `insert-file-contents'.
6194 Each is passed one argument, the number of bytes inserted. It should return
6195 the new byte count, and leave point the same. If `insert-file-contents' is
6196 intercepted by a handler from `file-name-handler-alist', that handler is
6197 responsible for calling the after-insert-file-functions if appropriate. */);
6198 Vafter_insert_file_functions
= Qnil
;
6200 DEFVAR_LISP ("write-region-annotate-functions", &Vwrite_region_annotate_functions
,
6201 doc
: /* A list of functions to be called at the start of `write-region'.
6202 Each is passed two arguments, START and END as for `write-region'.
6203 These are usually two numbers but not always; see the documentation
6204 for `write-region'. The function should return a list of pairs
6205 of the form (POSITION . STRING), consisting of strings to be effectively
6206 inserted at the specified positions of the file being written (1 means to
6207 insert before the first byte written). The POSITIONs must be sorted into
6208 increasing order. If there are several functions in the list, the several
6209 lists are merged destructively. */);
6210 Vwrite_region_annotate_functions
= Qnil
;
6212 DEFVAR_LISP ("write-region-annotations-so-far",
6213 &Vwrite_region_annotations_so_far
,
6214 doc
: /* When an annotation function is called, this holds the previous annotations.
6215 These are the annotations made by other annotation functions
6216 that were already called. See also `write-region-annotate-functions'. */);
6217 Vwrite_region_annotations_so_far
= Qnil
;
6219 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers
,
6220 doc
: /* A list of file name handlers that temporarily should not be used.
6221 This applies only to the operation `inhibit-file-name-operation'. */);
6222 Vinhibit_file_name_handlers
= Qnil
;
6224 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation
,
6225 doc
: /* The operation for which `inhibit-file-name-handlers' is applicable. */);
6226 Vinhibit_file_name_operation
= Qnil
;
6228 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name
,
6229 doc
: /* File name in which we write a list of all auto save file names.
6230 This variable is initialized automatically from `auto-save-list-file-prefix'
6231 shortly after Emacs reads your `.emacs' file, if you have not yet given it
6232 a non-nil value. */);
6233 Vauto_save_list_file_name
= Qnil
;
6235 defsubr (&Sfind_file_name_handler
);
6236 defsubr (&Sfile_name_directory
);
6237 defsubr (&Sfile_name_nondirectory
);
6238 defsubr (&Sunhandled_file_name_directory
);
6239 defsubr (&Sfile_name_as_directory
);
6240 defsubr (&Sdirectory_file_name
);
6241 defsubr (&Smake_temp_name
);
6242 defsubr (&Sexpand_file_name
);
6243 defsubr (&Ssubstitute_in_file_name
);
6244 defsubr (&Scopy_file
);
6245 defsubr (&Smake_directory_internal
);
6246 defsubr (&Sdelete_directory
);
6247 defsubr (&Sdelete_file
);
6248 defsubr (&Srename_file
);
6249 defsubr (&Sadd_name_to_file
);
6251 defsubr (&Smake_symbolic_link
);
6252 #endif /* S_IFLNK */
6254 defsubr (&Sdefine_logical_name
);
6257 defsubr (&Ssysnetunam
);
6258 #endif /* HPUX_NET */
6259 defsubr (&Sfile_name_absolute_p
);
6260 defsubr (&Sfile_exists_p
);
6261 defsubr (&Sfile_executable_p
);
6262 defsubr (&Sfile_readable_p
);
6263 defsubr (&Sfile_writable_p
);
6264 defsubr (&Saccess_file
);
6265 defsubr (&Sfile_symlink_p
);
6266 defsubr (&Sfile_directory_p
);
6267 defsubr (&Sfile_accessible_directory_p
);
6268 defsubr (&Sfile_regular_p
);
6269 defsubr (&Sfile_modes
);
6270 defsubr (&Sset_file_modes
);
6271 defsubr (&Sset_default_file_modes
);
6272 defsubr (&Sdefault_file_modes
);
6273 defsubr (&Sfile_newer_than_file_p
);
6274 defsubr (&Sinsert_file_contents
);
6275 defsubr (&Swrite_region
);
6276 defsubr (&Scar_less_than_car
);
6277 defsubr (&Sverify_visited_file_modtime
);
6278 defsubr (&Sclear_visited_file_modtime
);
6279 defsubr (&Svisited_file_modtime
);
6280 defsubr (&Sset_visited_file_modtime
);
6281 defsubr (&Sdo_auto_save
);
6282 defsubr (&Sset_buffer_auto_saved
);
6283 defsubr (&Sclear_buffer_auto_save_failure
);
6284 defsubr (&Srecent_auto_save_p
);
6286 defsubr (&Sread_file_name_internal
);
6287 defsubr (&Sread_file_name
);
6290 defsubr (&Sunix_sync
);