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
, result
;
343 CHECK_STRING (filename
);
345 if (EQ (operation
, Vinhibit_file_name_operation
))
346 inhibited_handlers
= Vinhibit_file_name_handlers
;
348 inhibited_handlers
= Qnil
;
350 for (chain
= Vfile_name_handler_alist
; CONSP (chain
);
351 chain
= XCDR (chain
))
361 && (match_pos
= fast_string_match (string
, filename
)) > pos
)
363 Lisp_Object handler
, tem
;
365 handler
= XCDR (elt
);
366 tem
= Fmemq (handler
, inhibited_handlers
);
380 DEFUN ("file-name-directory", Ffile_name_directory
, Sfile_name_directory
,
382 doc
: /* Return the directory component in file name FILENAME.
383 Return nil if FILENAME does not include a directory.
384 Otherwise return a directory spec.
385 Given a Unix syntax file name, returns a string ending in slash;
386 on VMS, perhaps instead a string ending in `:', `]' or `>'. */)
388 Lisp_Object filename
;
390 register unsigned char *beg
;
391 register unsigned char *p
;
394 CHECK_STRING (filename
);
396 /* If the file name has special constructs in it,
397 call the corresponding file handler. */
398 handler
= Ffind_file_name_handler (filename
, Qfile_name_directory
);
400 return call2 (handler
, Qfile_name_directory
, filename
);
402 #ifdef FILE_SYSTEM_CASE
403 filename
= FILE_SYSTEM_CASE (filename
);
405 beg
= XSTRING (filename
)->data
;
407 beg
= strcpy (alloca (strlen (beg
) + 1), beg
);
409 p
= beg
+ STRING_BYTES (XSTRING (filename
));
411 while (p
!= beg
&& !IS_DIRECTORY_SEP (p
[-1])
413 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
416 /* only recognise drive specifier at the beginning */
418 /* handle the "/:d:foo" and "/:foo" cases correctly */
419 && ((p
== beg
+ 2 && !IS_DIRECTORY_SEP (*beg
))
420 || (p
== beg
+ 4 && IS_DIRECTORY_SEP (*beg
))))
427 /* Expansion of "c:" to drive and default directory. */
430 /* MAXPATHLEN+1 is guaranteed to be enough space for getdefdir. */
431 unsigned char *res
= alloca (MAXPATHLEN
+ 1);
432 unsigned char *r
= res
;
434 if (p
== beg
+ 4 && IS_DIRECTORY_SEP (*beg
) && beg
[1] == ':')
436 strncpy (res
, beg
, 2);
441 if (getdefdir (toupper (*beg
) - 'A' + 1, r
))
443 if (!IS_DIRECTORY_SEP (res
[strlen (res
) - 1]))
446 p
= beg
+ strlen (beg
);
449 CORRECT_DIR_SEPS (beg
);
452 if (STRING_MULTIBYTE (filename
))
453 return make_string (beg
, p
- beg
);
454 return make_unibyte_string (beg
, p
- beg
);
457 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory
,
458 Sfile_name_nondirectory
, 1, 1, 0,
459 doc
: /* Return file name FILENAME sans its directory.
460 For example, in a Unix-syntax file name,
461 this is everything after the last slash,
462 or the entire name if it contains no slash. */)
464 Lisp_Object filename
;
466 register unsigned char *beg
, *p
, *end
;
469 CHECK_STRING (filename
);
471 /* If the file name has special constructs in it,
472 call the corresponding file handler. */
473 handler
= Ffind_file_name_handler (filename
, Qfile_name_nondirectory
);
475 return call2 (handler
, Qfile_name_nondirectory
, filename
);
477 beg
= XSTRING (filename
)->data
;
478 end
= p
= beg
+ STRING_BYTES (XSTRING (filename
));
480 while (p
!= beg
&& !IS_DIRECTORY_SEP (p
[-1])
482 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
485 /* only recognise drive specifier at beginning */
487 /* handle the "/:d:foo" case correctly */
488 && (p
== beg
+ 2 || (p
== beg
+ 4 && IS_DIRECTORY_SEP (*beg
))))
493 if (STRING_MULTIBYTE (filename
))
494 return make_string (p
, end
- p
);
495 return make_unibyte_string (p
, end
- p
);
498 DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory
,
499 Sunhandled_file_name_directory
, 1, 1, 0,
500 doc
: /* Return a directly usable directory name somehow associated with FILENAME.
501 A `directly usable' directory name is one that may be used without the
502 intervention of any file handler.
503 If FILENAME is a directly usable file itself, return
504 \(file-name-directory FILENAME).
505 The `call-process' and `start-process' functions use this function to
506 get a current directory to run processes in. */)
508 Lisp_Object filename
;
512 /* If the file name has special constructs in it,
513 call the corresponding file handler. */
514 handler
= Ffind_file_name_handler (filename
, Qunhandled_file_name_directory
);
516 return call2 (handler
, Qunhandled_file_name_directory
, filename
);
518 return Ffile_name_directory (filename
);
523 file_name_as_directory (out
, in
)
526 int size
= strlen (in
) - 1;
539 /* Is it already a directory string? */
540 if (in
[size
] == ':' || in
[size
] == ']' || in
[size
] == '>')
542 /* Is it a VMS directory file name? If so, hack VMS syntax. */
543 else if (! index (in
, '/')
544 && ((size
> 3 && ! strcmp (&in
[size
- 3], ".DIR"))
545 || (size
> 3 && ! strcmp (&in
[size
- 3], ".dir"))
546 || (size
> 5 && (! strncmp (&in
[size
- 5], ".DIR", 4)
547 || ! strncmp (&in
[size
- 5], ".dir", 4))
548 && (in
[size
- 1] == '.' || in
[size
- 1] == ';')
549 && in
[size
] == '1')))
551 register char *p
, *dot
;
555 dir:x.dir --> dir:[x]
556 dir:[x]y.dir --> dir:[x.y] */
558 while (p
!= in
&& *p
!= ':' && *p
!= '>' && *p
!= ']') p
--;
561 strncpy (out
, in
, p
- in
);
580 dot
= index (p
, '.');
583 /* blindly remove any extension */
584 size
= strlen (out
) + (dot
- p
);
585 strncat (out
, p
, dot
- p
);
596 /* For Unix syntax, Append a slash if necessary */
597 if (!IS_DIRECTORY_SEP (out
[size
]))
599 out
[size
+ 1] = DIRECTORY_SEP
;
600 out
[size
+ 2] = '\0';
603 CORRECT_DIR_SEPS (out
);
609 DEFUN ("file-name-as-directory", Ffile_name_as_directory
,
610 Sfile_name_as_directory
, 1, 1, 0,
611 doc
: /* Return a string representing file FILENAME interpreted as a directory.
612 This operation exists because a directory is also a file, but its name as
613 a directory is different from its name as a file.
614 The result can be used as the value of `default-directory'
615 or passed as second argument to `expand-file-name'.
616 For a Unix-syntax file name, just appends a slash.
617 On VMS, converts \"[X]FOO.DIR\" to \"[X.FOO]\", etc. */)
628 /* If the file name has special constructs in it,
629 call the corresponding file handler. */
630 handler
= Ffind_file_name_handler (file
, Qfile_name_as_directory
);
632 return call2 (handler
, Qfile_name_as_directory
, file
);
634 buf
= (char *) alloca (STRING_BYTES (XSTRING (file
)) + 10);
635 return build_string (file_name_as_directory (buf
, XSTRING (file
)->data
));
639 * Convert from directory name to filename.
641 * xyzzy:[mukesh.emacs] => xyzzy:[mukesh]emacs.dir.1
642 * xyzzy:[mukesh] => xyzzy:[000000]mukesh.dir.1
643 * On UNIX, it's simple: just make sure there isn't a terminating /
645 * Value is nonzero if the string output is different from the input.
649 directory_file_name (src
, dst
)
657 struct FAB fab
= cc$rms_fab
;
658 struct NAM nam
= cc$rms_nam
;
659 char esa
[NAM$C_MAXRSS
];
664 if (! index (src
, '/')
665 && (src
[slen
- 1] == ']'
666 || src
[slen
- 1] == ':'
667 || src
[slen
- 1] == '>'))
669 /* VMS style - convert [x.y.z] to [x.y]z, [x] to [000000]x */
671 fab
.fab$b_fns
= slen
;
672 fab
.fab$l_nam
= &nam
;
673 fab
.fab$l_fop
= FAB$M_NAM
;
676 nam
.nam$b_ess
= sizeof esa
;
677 nam
.nam$b_nop
|= NAM$M_SYNCHK
;
679 /* We call SYS$PARSE to handle such things as [--] for us. */
680 if (SYS$
PARSE (&fab
, 0, 0) == RMS$_NORMAL
)
682 slen
= nam
.nam$b_esl
;
683 if (esa
[slen
- 1] == ';' && esa
[slen
- 2] == '.')
688 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
690 /* what about when we have logical_name:???? */
691 if (src
[slen
- 1] == ':')
692 { /* Xlate logical name and see what we get */
693 ptr
= strcpy (dst
, src
); /* upper case for getenv */
696 if ('a' <= *ptr
&& *ptr
<= 'z')
700 dst
[slen
- 1] = 0; /* remove colon */
701 if (!(src
= egetenv (dst
)))
703 /* should we jump to the beginning of this procedure?
704 Good points: allows us to use logical names that xlate
706 Bad points: can be a problem if we just translated to a device
708 For now, I'll punt and always expect VMS names, and hope for
711 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
712 { /* no recursion here! */
718 { /* not a directory spec */
723 bracket
= src
[slen
- 1];
725 /* If bracket is ']' or '>', bracket - 2 is the corresponding
727 ptr
= index (src
, bracket
- 2);
729 { /* no opening bracket */
733 if (!(rptr
= rindex (src
, '.')))
736 strncpy (dst
, src
, slen
);
740 dst
[slen
++] = bracket
;
745 /* If we have the top-level of a rooted directory (i.e. xx:[000000]),
746 then translate the device and recurse. */
747 if (dst
[slen
- 1] == ':'
748 && dst
[slen
- 2] != ':' /* skip decnet nodes */
749 && strcmp (src
+ slen
, "[000000]") == 0)
751 dst
[slen
- 1] = '\0';
752 if ((ptr
= egetenv (dst
))
753 && (rlen
= strlen (ptr
) - 1) > 0
754 && (ptr
[rlen
] == ']' || ptr
[rlen
] == '>')
755 && ptr
[rlen
- 1] == '.')
757 char * buf
= (char *) alloca (strlen (ptr
) + 1);
761 return directory_file_name (buf
, dst
);
766 strcat (dst
, "[000000]");
770 rlen
= strlen (rptr
) - 1;
771 strncat (dst
, rptr
, rlen
);
772 dst
[slen
+ rlen
] = '\0';
773 strcat (dst
, ".DIR.1");
777 /* Process as Unix format: just remove any final slash.
778 But leave "/" unchanged; do not change it to "". */
781 /* Handle // as root for apollo's. */
782 if ((slen
> 2 && dst
[slen
- 1] == '/')
783 || (slen
> 1 && dst
[0] != '/' && dst
[slen
- 1] == '/'))
787 && IS_DIRECTORY_SEP (dst
[slen
- 1])
789 && !IS_ANY_SEP (dst
[slen
- 2])
795 CORRECT_DIR_SEPS (dst
);
800 DEFUN ("directory-file-name", Fdirectory_file_name
, Sdirectory_file_name
,
802 doc
: /* Returns the file name of the directory named DIRECTORY.
803 This is the name of the file that holds the data for the directory DIRECTORY.
804 This operation exists because a directory is also a file, but its name as
805 a directory is different from its name as a file.
806 In Unix-syntax, this function just removes the final slash.
807 On VMS, given a VMS-syntax directory name such as \"[X.Y]\",
808 it returns a file name such as \"[X]Y.DIR.1\". */)
810 Lisp_Object directory
;
815 CHECK_STRING (directory
);
817 if (NILP (directory
))
820 /* If the file name has special constructs in it,
821 call the corresponding file handler. */
822 handler
= Ffind_file_name_handler (directory
, Qdirectory_file_name
);
824 return call2 (handler
, Qdirectory_file_name
, directory
);
827 /* 20 extra chars is insufficient for VMS, since we might perform a
828 logical name translation. an equivalence string can be up to 255
829 chars long, so grab that much extra space... - sss */
830 buf
= (char *) alloca (STRING_BYTES (XSTRING (directory
)) + 20 + 255);
832 buf
= (char *) alloca (STRING_BYTES (XSTRING (directory
)) + 20);
834 directory_file_name (XSTRING (directory
)->data
, buf
);
835 return build_string (buf
);
838 static char make_temp_name_tbl
[64] =
840 'A','B','C','D','E','F','G','H',
841 'I','J','K','L','M','N','O','P',
842 'Q','R','S','T','U','V','W','X',
843 'Y','Z','a','b','c','d','e','f',
844 'g','h','i','j','k','l','m','n',
845 'o','p','q','r','s','t','u','v',
846 'w','x','y','z','0','1','2','3',
847 '4','5','6','7','8','9','-','_'
850 static unsigned make_temp_name_count
, make_temp_name_count_initialized_p
;
852 /* Value is a temporary file name starting with PREFIX, a string.
854 The Emacs process number forms part of the result, so there is
855 no danger of generating a name being used by another process.
856 In addition, this function makes an attempt to choose a name
857 which has no existing file. To make this work, PREFIX should be
858 an absolute file name.
860 BASE64_P non-zero means add the pid as 3 characters in base64
861 encoding. In this case, 6 characters will be added to PREFIX to
862 form the file name. Otherwise, if Emacs is running on a system
863 with long file names, add the pid as a decimal number.
865 This function signals an error if no unique file name could be
869 make_temp_name (prefix
, base64_p
)
876 unsigned char *p
, *data
;
880 CHECK_STRING (prefix
);
882 /* VAL is created by adding 6 characters to PREFIX. The first
883 three are the PID of this process, in base 64, and the second
884 three are incremented if the file already exists. This ensures
885 262144 unique file names per PID per PREFIX. */
887 pid
= (int) getpid ();
891 pidbuf
[0] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
892 pidbuf
[1] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
893 pidbuf
[2] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
898 #ifdef HAVE_LONG_FILE_NAMES
899 sprintf (pidbuf
, "%d", pid
);
900 pidlen
= strlen (pidbuf
);
902 pidbuf
[0] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
903 pidbuf
[1] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
904 pidbuf
[2] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
909 len
= XSTRING (prefix
)->size
;
910 val
= make_uninit_string (len
+ 3 + pidlen
);
911 data
= XSTRING (val
)->data
;
912 bcopy(XSTRING (prefix
)->data
, data
, len
);
915 bcopy (pidbuf
, p
, pidlen
);
918 /* Here we try to minimize useless stat'ing when this function is
919 invoked many times successively with the same PREFIX. We achieve
920 this by initializing count to a random value, and incrementing it
923 We don't want make-temp-name to be called while dumping,
924 because then make_temp_name_count_initialized_p would get set
925 and then make_temp_name_count would not be set when Emacs starts. */
927 if (!make_temp_name_count_initialized_p
)
929 make_temp_name_count
= (unsigned) time (NULL
);
930 make_temp_name_count_initialized_p
= 1;
936 unsigned num
= make_temp_name_count
;
938 p
[0] = make_temp_name_tbl
[num
& 63], num
>>= 6;
939 p
[1] = make_temp_name_tbl
[num
& 63], num
>>= 6;
940 p
[2] = make_temp_name_tbl
[num
& 63], num
>>= 6;
942 /* Poor man's congruential RN generator. Replace with
943 ++make_temp_name_count for debugging. */
944 make_temp_name_count
+= 25229;
945 make_temp_name_count
%= 225307;
947 if (stat (data
, &ignored
) < 0)
949 /* We want to return only if errno is ENOENT. */
953 /* The error here is dubious, but there is little else we
954 can do. The alternatives are to return nil, which is
955 as bad as (and in many cases worse than) throwing the
956 error, or to ignore the error, which will likely result
957 in looping through 225307 stat's, which is not only
958 dog-slow, but also useless since it will fallback to
959 the errow below, anyway. */
960 report_file_error ("Cannot create temporary name for prefix",
961 Fcons (prefix
, Qnil
));
966 error ("Cannot create temporary name for prefix `%s'",
967 XSTRING (prefix
)->data
);
972 DEFUN ("make-temp-name", Fmake_temp_name
, Smake_temp_name
, 1, 1, 0,
973 doc
: /* Generate temporary file name (string) starting with PREFIX (a string).
974 The Emacs process number forms part of the result,
975 so there is no danger of generating a name being used by another process.
977 In addition, this function makes an attempt to choose a name
978 which has no existing file. To make this work,
979 PREFIX should be an absolute file name.
981 There is a race condition between calling `make-temp-name' and creating the
982 file which opens all kinds of security holes. For that reason, you should
983 probably use `make-temp-file' instead. */)
987 return make_temp_name (prefix
, 0);
992 DEFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
993 doc
: /* Convert filename NAME to absolute, and canonicalize it.
994 Second arg DEFAULT-DIRECTORY is directory to start with if NAME is relative
995 (does not start with slash); if DEFAULT-DIRECTORY is nil or missing,
996 the current buffer's value of default-directory is used.
997 File name components that are `.' are removed, and
998 so are file name components followed by `..', along with the `..' itself;
999 note that these simplifications are done without checking the resulting
1000 file names in the file system.
1001 An initial `~/' expands to your home directory.
1002 An initial `~USER/' expands to USER's home directory.
1003 See also the function `substitute-in-file-name'. */)
1004 (name
, default_directory
)
1005 Lisp_Object name
, default_directory
;
1009 register unsigned char *newdir
, *p
, *o
;
1011 unsigned char *target
;
1014 unsigned char * colon
= 0;
1015 unsigned char * close
= 0;
1016 unsigned char * slash
= 0;
1017 unsigned char * brack
= 0;
1018 int lbrack
= 0, rbrack
= 0;
1023 int collapse_newdir
= 1;
1027 Lisp_Object handler
;
1029 CHECK_STRING (name
);
1031 /* If the file name has special constructs in it,
1032 call the corresponding file handler. */
1033 handler
= Ffind_file_name_handler (name
, Qexpand_file_name
);
1034 if (!NILP (handler
))
1035 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
1037 /* Use the buffer's default-directory if DEFAULT_DIRECTORY is omitted. */
1038 if (NILP (default_directory
))
1039 default_directory
= current_buffer
->directory
;
1040 if (! STRINGP (default_directory
))
1041 default_directory
= build_string ("/");
1043 if (!NILP (default_directory
))
1045 handler
= Ffind_file_name_handler (default_directory
, Qexpand_file_name
);
1046 if (!NILP (handler
))
1047 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
1050 o
= XSTRING (default_directory
)->data
;
1052 /* Make sure DEFAULT_DIRECTORY is properly expanded.
1053 It would be better to do this down below where we actually use
1054 default_directory. Unfortunately, calling Fexpand_file_name recursively
1055 could invoke GC, and the strings might be relocated. This would
1056 be annoying because we have pointers into strings lying around
1057 that would need adjusting, and people would add new pointers to
1058 the code and forget to adjust them, resulting in intermittent bugs.
1059 Putting this call here avoids all that crud.
1061 The EQ test avoids infinite recursion. */
1062 if (! NILP (default_directory
) && !EQ (default_directory
, name
)
1063 /* Save time in some common cases - as long as default_directory
1064 is not relative, it can be canonicalized with name below (if it
1065 is needed at all) without requiring it to be expanded now. */
1067 /* Detect MSDOS file names with drive specifiers. */
1068 && ! (IS_DRIVE (o
[0]) && IS_DEVICE_SEP (o
[1]) && IS_DIRECTORY_SEP (o
[2]))
1070 /* Detect Windows file names in UNC format. */
1071 && ! (IS_DIRECTORY_SEP (o
[0]) && IS_DIRECTORY_SEP (o
[1]))
1073 #else /* not DOS_NT */
1074 /* Detect Unix absolute file names (/... alone is not absolute on
1076 && ! (IS_DIRECTORY_SEP (o
[0]))
1077 #endif /* not DOS_NT */
1080 struct gcpro gcpro1
;
1083 default_directory
= Fexpand_file_name (default_directory
, Qnil
);
1088 /* Filenames on VMS are always upper case. */
1089 name
= Fupcase (name
);
1091 #ifdef FILE_SYSTEM_CASE
1092 name
= FILE_SYSTEM_CASE (name
);
1095 nm
= XSTRING (name
)->data
;
1098 /* We will force directory separators to be either all \ or /, so make
1099 a local copy to modify, even if there ends up being no change. */
1100 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
1102 /* Note if special escape prefix is present, but remove for now. */
1103 if (nm
[0] == '/' && nm
[1] == ':')
1109 /* Find and remove drive specifier if present; this makes nm absolute
1110 even if the rest of the name appears to be relative. Only look for
1111 drive specifier at the beginning. */
1112 if (IS_DRIVE (nm
[0]) && IS_DEVICE_SEP (nm
[1]))
1119 /* If we see "c://somedir", we want to strip the first slash after the
1120 colon when stripping the drive letter. Otherwise, this expands to
1122 if (drive
&& IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1124 #endif /* WINDOWSNT */
1128 /* Discard any previous drive specifier if nm is now in UNC format. */
1129 if (IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1135 /* If nm is absolute, look for `/./' or `/../' or `//''sequences; if
1136 none are found, we can probably return right away. We will avoid
1137 allocating a new string if name is already fully expanded. */
1139 IS_DIRECTORY_SEP (nm
[0])
1141 && drive
&& !is_escaped
1144 && (drive
|| IS_DIRECTORY_SEP (nm
[1])) && !is_escaped
1151 /* If it turns out that the filename we want to return is just a
1152 suffix of FILENAME, we don't need to go through and edit
1153 things; we just need to construct a new string using data
1154 starting at the middle of FILENAME. If we set lose to a
1155 non-zero value, that means we've discovered that we can't do
1162 /* Since we know the name is absolute, we can assume that each
1163 element starts with a "/". */
1165 /* "." and ".." are hairy. */
1166 if (IS_DIRECTORY_SEP (p
[0])
1168 && (IS_DIRECTORY_SEP (p
[2])
1170 || (p
[2] == '.' && (IS_DIRECTORY_SEP (p
[3])
1173 /* We want to replace multiple `/' in a row with a single
1176 && IS_DIRECTORY_SEP (p
[0])
1177 && IS_DIRECTORY_SEP (p
[1]))
1184 /* if dev:[dir]/, move nm to / */
1185 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1186 nm
= (brack
? brack
+ 1 : colon
+ 1);
1187 lbrack
= rbrack
= 0;
1195 /* VMS pre V4.4,convert '-'s in filenames. */
1196 if (lbrack
== rbrack
)
1198 if (dots
< 2) /* this is to allow negative version numbers */
1203 if (lbrack
> rbrack
&&
1204 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1205 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1211 /* count open brackets, reset close bracket pointer */
1212 if (p
[0] == '[' || p
[0] == '<')
1213 lbrack
++, brack
= 0;
1214 /* count close brackets, set close bracket pointer */
1215 if (p
[0] == ']' || p
[0] == '>')
1216 rbrack
++, brack
= p
;
1217 /* detect ][ or >< */
1218 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1220 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1221 nm
= p
+ 1, lose
= 1;
1222 if (p
[0] == ':' && (colon
|| slash
))
1223 /* if dev1:[dir]dev2:, move nm to dev2: */
1229 /* if /name/dev:, move nm to dev: */
1232 /* if node::dev:, move colon following dev */
1233 else if (colon
&& colon
[-1] == ':')
1235 /* if dev1:dev2:, move nm to dev2: */
1236 else if (colon
&& colon
[-1] != ':')
1241 if (p
[0] == ':' && !colon
)
1247 if (lbrack
== rbrack
)
1250 else if (p
[0] == '.')
1258 if (index (nm
, '/'))
1259 return build_string (sys_translate_unix (nm
));
1262 /* Make sure directories are all separated with / or \ as
1263 desired, but avoid allocation of a new string when not
1265 CORRECT_DIR_SEPS (nm
);
1267 if (IS_DIRECTORY_SEP (nm
[1]))
1269 if (strcmp (nm
, XSTRING (name
)->data
) != 0)
1270 name
= build_string (nm
);
1274 /* drive must be set, so this is okay */
1275 if (strcmp (nm
- 2, XSTRING (name
)->data
) != 0)
1277 name
= make_string (nm
- 2, p
- nm
+ 2);
1278 XSTRING (name
)->data
[0] = DRIVE_LETTER (drive
);
1279 XSTRING (name
)->data
[1] = ':';
1282 #else /* not DOS_NT */
1283 if (nm
== XSTRING (name
)->data
)
1285 return build_string (nm
);
1286 #endif /* not DOS_NT */
1290 /* At this point, nm might or might not be an absolute file name. We
1291 need to expand ~ or ~user if present, otherwise prefix nm with
1292 default_directory if nm is not absolute, and finally collapse /./
1293 and /foo/../ sequences.
1295 We set newdir to be the appropriate prefix if one is needed:
1296 - the relevant user directory if nm starts with ~ or ~user
1297 - the specified drive's working dir (DOS/NT only) if nm does not
1299 - the value of default_directory.
1301 Note that these prefixes are not guaranteed to be absolute (except
1302 for the working dir of a drive). Therefore, to ensure we always
1303 return an absolute name, if the final prefix is not absolute we
1304 append it to the current working directory. */
1308 if (nm
[0] == '~') /* prefix ~ */
1310 if (IS_DIRECTORY_SEP (nm
[1])
1314 || nm
[1] == 0) /* ~ by itself */
1316 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1317 newdir
= (unsigned char *) "";
1320 collapse_newdir
= 0;
1323 nm
++; /* Don't leave the slash in nm. */
1326 else /* ~user/filename */
1328 for (p
= nm
; *p
&& (!IS_DIRECTORY_SEP (*p
)
1333 o
= (unsigned char *) alloca (p
- nm
+ 1);
1334 bcopy ((char *) nm
, o
, p
- nm
);
1337 pw
= (struct passwd
*) getpwnam (o
+ 1);
1340 newdir
= (unsigned char *) pw
-> pw_dir
;
1342 nm
= p
+ 1; /* skip the terminator */
1346 collapse_newdir
= 0;
1351 /* If we don't find a user of that name, leave the name
1352 unchanged; don't move nm forward to p. */
1357 /* On DOS and Windows, nm is absolute if a drive name was specified;
1358 use the drive's current directory as the prefix if needed. */
1359 if (!newdir
&& drive
)
1361 /* Get default directory if needed to make nm absolute. */
1362 if (!IS_DIRECTORY_SEP (nm
[0]))
1364 newdir
= alloca (MAXPATHLEN
+ 1);
1365 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1370 /* Either nm starts with /, or drive isn't mounted. */
1371 newdir
= alloca (4);
1372 newdir
[0] = DRIVE_LETTER (drive
);
1380 /* Finally, if no prefix has been specified and nm is not absolute,
1381 then it must be expanded relative to default_directory. */
1385 /* /... alone is not absolute on DOS and Windows. */
1386 && !IS_DIRECTORY_SEP (nm
[0])
1389 && !(IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1396 newdir
= XSTRING (default_directory
)->data
;
1398 /* Note if special escape prefix is present, but remove for now. */
1399 if (newdir
[0] == '/' && newdir
[1] == ':')
1410 /* First ensure newdir is an absolute name. */
1412 /* Detect MSDOS file names with drive specifiers. */
1413 ! (IS_DRIVE (newdir
[0])
1414 && IS_DEVICE_SEP (newdir
[1]) && IS_DIRECTORY_SEP (newdir
[2]))
1416 /* Detect Windows file names in UNC format. */
1417 && ! (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1421 /* Effectively, let newdir be (expand-file-name newdir cwd).
1422 Because of the admonition against calling expand-file-name
1423 when we have pointers into lisp strings, we accomplish this
1424 indirectly by prepending newdir to nm if necessary, and using
1425 cwd (or the wd of newdir's drive) as the new newdir. */
1427 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1432 if (!IS_DIRECTORY_SEP (nm
[0]))
1434 char * tmp
= alloca (strlen (newdir
) + strlen (nm
) + 2);
1435 file_name_as_directory (tmp
, newdir
);
1439 newdir
= alloca (MAXPATHLEN
+ 1);
1442 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1449 /* Strip off drive name from prefix, if present. */
1450 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1456 /* Keep only a prefix from newdir if nm starts with slash
1457 (//server/share for UNC, nothing otherwise). */
1458 if (IS_DIRECTORY_SEP (nm
[0]) && collapse_newdir
)
1461 if (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1463 newdir
= strcpy (alloca (strlen (newdir
) + 1), newdir
);
1465 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1467 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1479 /* Get rid of any slash at the end of newdir, unless newdir is
1480 just / or // (an incomplete UNC name). */
1481 length
= strlen (newdir
);
1482 if (length
> 1 && IS_DIRECTORY_SEP (newdir
[length
- 1])
1484 && !(length
== 2 && IS_DIRECTORY_SEP (newdir
[0]))
1488 unsigned char *temp
= (unsigned char *) alloca (length
);
1489 bcopy (newdir
, temp
, length
- 1);
1490 temp
[length
- 1] = 0;
1498 /* Now concatenate the directory and name to new space in the stack frame */
1499 tlen
+= strlen (nm
) + 1;
1501 /* Reserve space for drive specifier and escape prefix, since either
1502 or both may need to be inserted. (The Microsoft x86 compiler
1503 produces incorrect code if the following two lines are combined.) */
1504 target
= (unsigned char *) alloca (tlen
+ 4);
1506 #else /* not DOS_NT */
1507 target
= (unsigned char *) alloca (tlen
);
1508 #endif /* not DOS_NT */
1514 if (nm
[0] == 0 || IS_DIRECTORY_SEP (nm
[0]))
1517 /* If newdir is effectively "C:/", then the drive letter will have
1518 been stripped and newdir will be "/". Concatenating with an
1519 absolute directory in nm produces "//", which will then be
1520 incorrectly treated as a network share. Ignore newdir in
1521 this case (keeping the drive letter). */
1522 if (!(drive
&& nm
[0] && IS_DIRECTORY_SEP (newdir
[0])
1523 && newdir
[1] == '\0'))
1525 strcpy (target
, newdir
);
1529 file_name_as_directory (target
, newdir
);
1532 strcat (target
, nm
);
1534 if (index (target
, '/'))
1535 strcpy (target
, sys_translate_unix (target
));
1538 /* ASSERT (IS_DIRECTORY_SEP (target[0])) if not VMS */
1540 /* Now canonicalize by removing `//', `/.' and `/foo/..' if they
1549 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1555 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1556 /* brackets are offset from each other by 2 */
1559 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1560 /* convert [foo][bar] to [bar] */
1561 while (o
[-1] != '[' && o
[-1] != '<')
1563 else if (*p
== '-' && *o
!= '.')
1566 else if (p
[0] == '-' && o
[-1] == '.' &&
1567 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1568 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1572 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1573 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1575 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1577 /* else [foo.-] ==> [-] */
1583 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1584 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1590 if (!IS_DIRECTORY_SEP (*p
))
1594 else if (IS_DIRECTORY_SEP (p
[0])
1596 && (IS_DIRECTORY_SEP (p
[2])
1599 /* If "/." is the entire filename, keep the "/". Otherwise,
1600 just delete the whole "/.". */
1601 if (o
== target
&& p
[2] == '\0')
1605 else if (IS_DIRECTORY_SEP (p
[0]) && p
[1] == '.' && p
[2] == '.'
1606 /* `/../' is the "superroot" on certain file systems. */
1608 && (IS_DIRECTORY_SEP (p
[3]) || p
[3] == 0))
1610 while (o
!= target
&& (--o
) && !IS_DIRECTORY_SEP (*o
))
1612 /* Keep initial / only if this is the whole name. */
1613 if (o
== target
&& IS_ANY_SEP (*o
) && p
[3] == 0)
1618 && IS_DIRECTORY_SEP (p
[0]) && IS_DIRECTORY_SEP (p
[1]))
1620 /* Collapse multiple `/' in a row. */
1622 while (IS_DIRECTORY_SEP (*p
))
1629 #endif /* not VMS */
1633 /* At last, set drive name. */
1635 /* Except for network file name. */
1636 if (!(IS_DIRECTORY_SEP (target
[0]) && IS_DIRECTORY_SEP (target
[1])))
1637 #endif /* WINDOWSNT */
1639 if (!drive
) abort ();
1641 target
[0] = DRIVE_LETTER (drive
);
1644 /* Reinsert the escape prefix if required. */
1651 CORRECT_DIR_SEPS (target
);
1654 return make_string (target
, o
- target
);
1658 /* PLEASE DO NOT DELETE THIS COMMENTED-OUT VERSION!
1659 This is the old version of expand-file-name, before it was thoroughly
1660 rewritten for Emacs 10.31. We leave this version here commented-out,
1661 because the code is very complex and likely to have subtle bugs. If
1662 bugs _are_ found, it might be of interest to look at the old code and
1663 see what did it do in the relevant situation.
1665 Don't remove this code: it's true that it will be accessible via CVS,
1666 but a few years from deletion, people will forget it is there. */
1668 /* Changed this DEFUN to a DEAFUN, so as not to confuse `make-docfile'. */
1669 DEAFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
1670 "Convert FILENAME to absolute, and canonicalize it.\n\
1671 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
1672 (does not start with slash); if DEFAULT is nil or missing,\n\
1673 the current buffer's value of default-directory is used.\n\
1674 Filenames containing `.' or `..' as components are simplified;\n\
1675 initial `~/' expands to your home directory.\n\
1676 See also the function `substitute-in-file-name'.")
1678 Lisp_Object name
, defalt
;
1682 register unsigned char *newdir
, *p
, *o
;
1684 unsigned char *target
;
1688 unsigned char * colon
= 0;
1689 unsigned char * close
= 0;
1690 unsigned char * slash
= 0;
1691 unsigned char * brack
= 0;
1692 int lbrack
= 0, rbrack
= 0;
1696 CHECK_STRING (name
);
1699 /* Filenames on VMS are always upper case. */
1700 name
= Fupcase (name
);
1703 nm
= XSTRING (name
)->data
;
1705 /* If nm is absolute, flush ...// and detect /./ and /../.
1706 If no /./ or /../ we can return right away. */
1718 if (p
[0] == '/' && p
[1] == '/'
1720 /* // at start of filename is meaningful on Apollo system. */
1725 if (p
[0] == '/' && p
[1] == '~')
1726 nm
= p
+ 1, lose
= 1;
1727 if (p
[0] == '/' && p
[1] == '.'
1728 && (p
[2] == '/' || p
[2] == 0
1729 || (p
[2] == '.' && (p
[3] == '/' || p
[3] == 0))))
1735 /* if dev:[dir]/, move nm to / */
1736 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1737 nm
= (brack
? brack
+ 1 : colon
+ 1);
1738 lbrack
= rbrack
= 0;
1746 /* VMS pre V4.4,convert '-'s in filenames. */
1747 if (lbrack
== rbrack
)
1749 if (dots
< 2) /* this is to allow negative version numbers */
1754 if (lbrack
> rbrack
&&
1755 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1756 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1762 /* count open brackets, reset close bracket pointer */
1763 if (p
[0] == '[' || p
[0] == '<')
1764 lbrack
++, brack
= 0;
1765 /* count close brackets, set close bracket pointer */
1766 if (p
[0] == ']' || p
[0] == '>')
1767 rbrack
++, brack
= p
;
1768 /* detect ][ or >< */
1769 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1771 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1772 nm
= p
+ 1, lose
= 1;
1773 if (p
[0] == ':' && (colon
|| slash
))
1774 /* if dev1:[dir]dev2:, move nm to dev2: */
1780 /* If /name/dev:, move nm to dev: */
1783 /* If node::dev:, move colon following dev */
1784 else if (colon
&& colon
[-1] == ':')
1786 /* If dev1:dev2:, move nm to dev2: */
1787 else if (colon
&& colon
[-1] != ':')
1792 if (p
[0] == ':' && !colon
)
1798 if (lbrack
== rbrack
)
1801 else if (p
[0] == '.')
1809 if (index (nm
, '/'))
1810 return build_string (sys_translate_unix (nm
));
1812 if (nm
== XSTRING (name
)->data
)
1814 return build_string (nm
);
1818 /* Now determine directory to start with and put it in NEWDIR */
1822 if (nm
[0] == '~') /* prefix ~ */
1827 || nm
[1] == 0)/* ~/filename */
1829 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1830 newdir
= (unsigned char *) "";
1833 nm
++; /* Don't leave the slash in nm. */
1836 else /* ~user/filename */
1838 /* Get past ~ to user */
1839 unsigned char *user
= nm
+ 1;
1840 /* Find end of name. */
1841 unsigned char *ptr
= (unsigned char *) index (user
, '/');
1842 int len
= ptr
? ptr
- user
: strlen (user
);
1844 unsigned char *ptr1
= index (user
, ':');
1845 if (ptr1
!= 0 && ptr1
- user
< len
)
1848 /* Copy the user name into temp storage. */
1849 o
= (unsigned char *) alloca (len
+ 1);
1850 bcopy ((char *) user
, o
, len
);
1853 /* Look up the user name. */
1854 pw
= (struct passwd
*) getpwnam (o
+ 1);
1856 error ("\"%s\" isn't a registered user", o
+ 1);
1858 newdir
= (unsigned char *) pw
->pw_dir
;
1860 /* Discard the user name from NM. */
1867 #endif /* not VMS */
1871 defalt
= current_buffer
->directory
;
1872 CHECK_STRING (defalt
);
1873 newdir
= XSTRING (defalt
)->data
;
1876 /* Now concatenate the directory and name to new space in the stack frame */
1878 tlen
= (newdir
? strlen (newdir
) + 1 : 0) + strlen (nm
) + 1;
1879 target
= (unsigned char *) alloca (tlen
);
1885 if (nm
[0] == 0 || nm
[0] == '/')
1886 strcpy (target
, newdir
);
1889 file_name_as_directory (target
, newdir
);
1892 strcat (target
, nm
);
1894 if (index (target
, '/'))
1895 strcpy (target
, sys_translate_unix (target
));
1898 /* Now canonicalize by removing /. and /foo/.. if they appear */
1906 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1912 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1913 /* brackets are offset from each other by 2 */
1916 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1917 /* convert [foo][bar] to [bar] */
1918 while (o
[-1] != '[' && o
[-1] != '<')
1920 else if (*p
== '-' && *o
!= '.')
1923 else if (p
[0] == '-' && o
[-1] == '.' &&
1924 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1925 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1929 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1930 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1932 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1934 /* else [foo.-] ==> [-] */
1940 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1941 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1951 else if (!strncmp (p
, "//", 2)
1953 /* // at start of filename is meaningful in Apollo system. */
1961 else if (p
[0] == '/' && p
[1] == '.' &&
1962 (p
[2] == '/' || p
[2] == 0))
1964 else if (!strncmp (p
, "/..", 3)
1965 /* `/../' is the "superroot" on certain file systems. */
1967 && (p
[3] == '/' || p
[3] == 0))
1969 while (o
!= target
&& *--o
!= '/')
1972 if (o
== target
+ 1 && o
[-1] == '/' && o
[0] == '/')
1976 if (o
== target
&& *o
== '/')
1984 #endif /* not VMS */
1987 return make_string (target
, o
- target
);
1991 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name
,
1992 Ssubstitute_in_file_name
, 1, 1, 0,
1993 doc
: /* Substitute environment variables referred to in FILENAME.
1994 `$FOO' where FOO is an environment variable name means to substitute
1995 the value of that variable. The variable name should be terminated
1996 with a character not a letter, digit or underscore; otherwise, enclose
1997 the entire variable name in braces.
1998 If `/~' appears, all of FILENAME through that `/' is discarded.
2000 On VMS, `$' substitution is not done; this function does little and only
2001 duplicates what `expand-file-name' does. */)
2003 Lisp_Object filename
;
2007 register unsigned char *s
, *p
, *o
, *x
, *endp
;
2008 unsigned char *target
= NULL
;
2010 int substituted
= 0;
2012 Lisp_Object handler
;
2014 CHECK_STRING (filename
);
2016 /* If the file name has special constructs in it,
2017 call the corresponding file handler. */
2018 handler
= Ffind_file_name_handler (filename
, Qsubstitute_in_file_name
);
2019 if (!NILP (handler
))
2020 return call2 (handler
, Qsubstitute_in_file_name
, filename
);
2022 nm
= XSTRING (filename
)->data
;
2024 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
2025 CORRECT_DIR_SEPS (nm
);
2026 substituted
= (strcmp (nm
, XSTRING (filename
)->data
) != 0);
2028 endp
= nm
+ STRING_BYTES (XSTRING (filename
));
2030 /* If /~ or // appears, discard everything through first slash. */
2032 for (p
= nm
; p
!= endp
; p
++)
2035 #if defined (APOLLO) || defined (WINDOWSNT)
2036 /* // at start of file name is meaningful in Apollo and
2037 WindowsNT systems. */
2038 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != nm
)
2039 #else /* not (APOLLO || WINDOWSNT) */
2040 || IS_DIRECTORY_SEP (p
[0])
2041 #endif /* not (APOLLO || WINDOWSNT) */
2046 || p
[-1] == ':' || p
[-1] == ']' || p
[-1] == '>'
2048 || IS_DIRECTORY_SEP (p
[-1])))
2054 /* see comment in expand-file-name about drive specifiers */
2055 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
2056 && p
> nm
&& IS_DIRECTORY_SEP (p
[-1]))
2065 return build_string (nm
);
2068 /* See if any variables are substituted into the string
2069 and find the total length of their values in `total' */
2071 for (p
= nm
; p
!= endp
;)
2081 /* "$$" means a single "$" */
2090 while (p
!= endp
&& *p
!= '}') p
++;
2091 if (*p
!= '}') goto missingclose
;
2097 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
2101 /* Copy out the variable name */
2102 target
= (unsigned char *) alloca (s
- o
+ 1);
2103 strncpy (target
, o
, s
- o
);
2106 strupr (target
); /* $home == $HOME etc. */
2109 /* Get variable value */
2110 o
= (unsigned char *) egetenv (target
);
2113 total
+= strlen (o
);
2123 /* If substitution required, recopy the string and do it */
2124 /* Make space in stack frame for the new copy */
2125 xnm
= (unsigned char *) alloca (STRING_BYTES (XSTRING (filename
)) + total
+ 1);
2128 /* Copy the rest of the name through, replacing $ constructs with values */
2145 while (p
!= endp
&& *p
!= '}') p
++;
2146 if (*p
!= '}') goto missingclose
;
2152 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
2156 /* Copy out the variable name */
2157 target
= (unsigned char *) alloca (s
- o
+ 1);
2158 strncpy (target
, o
, s
- o
);
2161 strupr (target
); /* $home == $HOME etc. */
2164 /* Get variable value */
2165 o
= (unsigned char *) egetenv (target
);
2169 strcpy (x
, target
); x
+= strlen (target
);
2171 else if (STRING_MULTIBYTE (filename
))
2173 /* If the original string is multibyte,
2174 convert what we substitute into multibyte. */
2177 int c
= unibyte_char_to_multibyte (*o
++);
2178 x
+= CHAR_STRING (c
, x
);
2190 /* If /~ or // appears, discard everything through first slash. */
2192 for (p
= xnm
; p
!= x
; p
++)
2194 #if defined (APOLLO) || defined (WINDOWSNT)
2195 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != xnm
)
2196 #else /* not (APOLLO || WINDOWSNT) */
2197 || IS_DIRECTORY_SEP (p
[0])
2198 #endif /* not (APOLLO || WINDOWSNT) */
2200 && p
!= xnm
&& IS_DIRECTORY_SEP (p
[-1]))
2203 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
2204 && p
> xnm
&& IS_DIRECTORY_SEP (p
[-1]))
2208 if (STRING_MULTIBYTE (filename
))
2209 return make_string (xnm
, x
- xnm
);
2210 return make_unibyte_string (xnm
, x
- xnm
);
2213 error ("Bad format environment-variable substitution");
2215 error ("Missing \"}\" in environment-variable substitution");
2217 error ("Substituting nonexistent environment variable \"%s\"", target
);
2220 #endif /* not VMS */
2224 /* A slightly faster and more convenient way to get
2225 (directory-file-name (expand-file-name FOO)). */
2228 expand_and_dir_to_file (filename
, defdir
)
2229 Lisp_Object filename
, defdir
;
2231 register Lisp_Object absname
;
2233 absname
= Fexpand_file_name (filename
, defdir
);
2236 register int c
= XSTRING (absname
)->data
[STRING_BYTES (XSTRING (absname
)) - 1];
2237 if (c
== ':' || c
== ']' || c
== '>')
2238 absname
= Fdirectory_file_name (absname
);
2241 /* Remove final slash, if any (unless this is the root dir).
2242 stat behaves differently depending! */
2243 if (XSTRING (absname
)->size
> 1
2244 && IS_DIRECTORY_SEP (XSTRING (absname
)->data
[STRING_BYTES (XSTRING (absname
)) - 1])
2245 && !IS_DEVICE_SEP (XSTRING (absname
)->data
[STRING_BYTES (XSTRING (absname
))-2]))
2246 /* We cannot take shortcuts; they might be wrong for magic file names. */
2247 absname
= Fdirectory_file_name (absname
);
2252 /* Signal an error if the file ABSNAME already exists.
2253 If INTERACTIVE is nonzero, ask the user whether to proceed,
2254 and bypass the error if the user says to go ahead.
2255 QUERYSTRING is a name for the action that is being considered
2258 *STATPTR is used to store the stat information if the file exists.
2259 If the file does not exist, STATPTR->st_mode is set to 0.
2260 If STATPTR is null, we don't store into it.
2262 If QUICK is nonzero, we ask for y or n, not yes or no. */
2265 barf_or_query_if_file_exists (absname
, querystring
, interactive
, statptr
, quick
)
2266 Lisp_Object absname
;
2267 unsigned char *querystring
;
2269 struct stat
*statptr
;
2272 register Lisp_Object tem
, encoded_filename
;
2273 struct stat statbuf
;
2274 struct gcpro gcpro1
;
2276 encoded_filename
= ENCODE_FILE (absname
);
2278 /* stat is a good way to tell whether the file exists,
2279 regardless of what access permissions it has. */
2280 if (stat (XSTRING (encoded_filename
)->data
, &statbuf
) >= 0)
2283 Fsignal (Qfile_already_exists
,
2284 Fcons (build_string ("File already exists"),
2285 Fcons (absname
, Qnil
)));
2287 tem
= format1 ("File %s already exists; %s anyway? ",
2288 XSTRING (absname
)->data
, querystring
);
2290 tem
= Fy_or_n_p (tem
);
2292 tem
= do_yes_or_no_p (tem
);
2295 Fsignal (Qfile_already_exists
,
2296 Fcons (build_string ("File already exists"),
2297 Fcons (absname
, Qnil
)));
2304 statptr
->st_mode
= 0;
2309 DEFUN ("copy-file", Fcopy_file
, Scopy_file
, 2, 4,
2310 "fCopy file: \nFCopy %s to file: \np\nP",
2311 doc
: /* Copy FILE to NEWNAME. Both args must be strings.
2312 If NEWNAME names a directory, copy FILE there.
2313 Signals a `file-already-exists' error if file NEWNAME already exists,
2314 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.
2315 A number as third arg means request confirmation if NEWNAME already exists.
2316 This is what happens in interactive use with M-x.
2317 Fourth arg KEEP-TIME non-nil means give the new file the same
2318 last-modified time as the old one. (This works on only some systems.)
2319 A prefix arg makes KEEP-TIME non-nil. */)
2320 (file
, newname
, ok_if_already_exists
, keep_time
)
2321 Lisp_Object file
, newname
, ok_if_already_exists
, keep_time
;
2324 char buf
[16 * 1024];
2325 struct stat st
, out_st
;
2326 Lisp_Object handler
;
2327 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2328 int count
= specpdl_ptr
- specpdl
;
2329 int input_file_statable_p
;
2330 Lisp_Object encoded_file
, encoded_newname
;
2332 encoded_file
= encoded_newname
= Qnil
;
2333 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2334 CHECK_STRING (file
);
2335 CHECK_STRING (newname
);
2337 if (!NILP (Ffile_directory_p (newname
)))
2338 newname
= Fexpand_file_name (file
, newname
);
2340 newname
= Fexpand_file_name (newname
, Qnil
);
2342 file
= Fexpand_file_name (file
, Qnil
);
2344 /* If the input file name has special constructs in it,
2345 call the corresponding file handler. */
2346 handler
= Ffind_file_name_handler (file
, Qcopy_file
);
2347 /* Likewise for output file name. */
2349 handler
= Ffind_file_name_handler (newname
, Qcopy_file
);
2350 if (!NILP (handler
))
2351 RETURN_UNGCPRO (call5 (handler
, Qcopy_file
, file
, newname
,
2352 ok_if_already_exists
, keep_time
));
2354 encoded_file
= ENCODE_FILE (file
);
2355 encoded_newname
= ENCODE_FILE (newname
);
2357 if (NILP (ok_if_already_exists
)
2358 || INTEGERP (ok_if_already_exists
))
2359 barf_or_query_if_file_exists (encoded_newname
, "copy to it",
2360 INTEGERP (ok_if_already_exists
), &out_st
, 0);
2361 else if (stat (XSTRING (encoded_newname
)->data
, &out_st
) < 0)
2365 if (!CopyFile (XSTRING (encoded_file
)->data
,
2366 XSTRING (encoded_newname
)->data
,
2368 report_file_error ("Copying file", Fcons (file
, Fcons (newname
, Qnil
)));
2369 else if (NILP (keep_time
))
2372 EMACS_GET_TIME (now
);
2373 if (set_file_times (XSTRING (encoded_newname
)->data
,
2375 Fsignal (Qfile_date_error
,
2376 Fcons (build_string ("Cannot set file date"),
2377 Fcons (newname
, Qnil
)));
2379 #else /* not WINDOWSNT */
2380 ifd
= emacs_open (XSTRING (encoded_file
)->data
, O_RDONLY
, 0);
2382 report_file_error ("Opening input file", Fcons (file
, Qnil
));
2384 record_unwind_protect (close_file_unwind
, make_number (ifd
));
2386 /* We can only copy regular files and symbolic links. Other files are not
2388 input_file_statable_p
= (fstat (ifd
, &st
) >= 0);
2390 #if !defined (DOS_NT) || __DJGPP__ > 1
2391 if (out_st
.st_mode
!= 0
2392 && st
.st_dev
== out_st
.st_dev
&& st
.st_ino
== out_st
.st_ino
)
2395 report_file_error ("Input and output files are the same",
2396 Fcons (file
, Fcons (newname
, Qnil
)));
2400 #if defined (S_ISREG) && defined (S_ISLNK)
2401 if (input_file_statable_p
)
2403 if (!(S_ISREG (st
.st_mode
)) && !(S_ISLNK (st
.st_mode
)))
2405 #if defined (EISDIR)
2406 /* Get a better looking error message. */
2409 report_file_error ("Non-regular file", Fcons (file
, Qnil
));
2412 #endif /* S_ISREG && S_ISLNK */
2415 /* Create the copy file with the same record format as the input file */
2416 ofd
= sys_creat (XSTRING (encoded_newname
)->data
, 0666, ifd
);
2419 /* System's default file type was set to binary by _fmode in emacs.c. */
2420 ofd
= creat (XSTRING (encoded_newname
)->data
, S_IREAD
| S_IWRITE
);
2421 #else /* not MSDOS */
2422 ofd
= creat (XSTRING (encoded_newname
)->data
, 0666);
2423 #endif /* not MSDOS */
2426 report_file_error ("Opening output file", Fcons (newname
, Qnil
));
2428 record_unwind_protect (close_file_unwind
, make_number (ofd
));
2432 while ((n
= emacs_read (ifd
, buf
, sizeof buf
)) > 0)
2433 if (emacs_write (ofd
, buf
, n
) != n
)
2434 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2437 /* Closing the output clobbers the file times on some systems. */
2438 if (emacs_close (ofd
) < 0)
2439 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2441 if (input_file_statable_p
)
2443 if (!NILP (keep_time
))
2445 EMACS_TIME atime
, mtime
;
2446 EMACS_SET_SECS_USECS (atime
, st
.st_atime
, 0);
2447 EMACS_SET_SECS_USECS (mtime
, st
.st_mtime
, 0);
2448 if (set_file_times (XSTRING (encoded_newname
)->data
,
2450 Fsignal (Qfile_date_error
,
2451 Fcons (build_string ("Cannot set file date"),
2452 Fcons (newname
, Qnil
)));
2455 chmod (XSTRING (encoded_newname
)->data
, st
.st_mode
& 07777);
2457 #if defined (__DJGPP__) && __DJGPP__ > 1
2458 /* In DJGPP v2.0 and later, fstat usually returns true file mode bits,
2459 and if it can't, it tells so. Otherwise, under MSDOS we usually
2460 get only the READ bit, which will make the copied file read-only,
2461 so it's better not to chmod at all. */
2462 if ((_djstat_flags
& _STFAIL_WRITEBIT
) == 0)
2463 chmod (XSTRING (encoded_newname
)->data
, st
.st_mode
& 07777);
2464 #endif /* DJGPP version 2 or newer */
2469 #endif /* WINDOWSNT */
2471 /* Discard the unwind protects. */
2472 specpdl_ptr
= specpdl
+ count
;
2478 DEFUN ("make-directory-internal", Fmake_directory_internal
,
2479 Smake_directory_internal
, 1, 1, 0,
2480 doc
: /* Create a new directory named DIRECTORY. */)
2482 Lisp_Object directory
;
2485 Lisp_Object handler
;
2486 Lisp_Object encoded_dir
;
2488 CHECK_STRING (directory
);
2489 directory
= Fexpand_file_name (directory
, Qnil
);
2491 handler
= Ffind_file_name_handler (directory
, Qmake_directory_internal
);
2492 if (!NILP (handler
))
2493 return call2 (handler
, Qmake_directory_internal
, directory
);
2495 encoded_dir
= ENCODE_FILE (directory
);
2497 dir
= XSTRING (encoded_dir
)->data
;
2500 if (mkdir (dir
) != 0)
2502 if (mkdir (dir
, 0777) != 0)
2504 report_file_error ("Creating directory", Flist (1, &directory
));
2509 DEFUN ("delete-directory", Fdelete_directory
, Sdelete_directory
, 1, 1, "FDelete directory: ",
2510 doc
: /* Delete the directory named DIRECTORY. */)
2512 Lisp_Object directory
;
2515 Lisp_Object handler
;
2516 Lisp_Object encoded_dir
;
2518 CHECK_STRING (directory
);
2519 directory
= Fdirectory_file_name (Fexpand_file_name (directory
, Qnil
));
2521 handler
= Ffind_file_name_handler (directory
, Qdelete_directory
);
2522 if (!NILP (handler
))
2523 return call2 (handler
, Qdelete_directory
, directory
);
2525 encoded_dir
= ENCODE_FILE (directory
);
2527 dir
= XSTRING (encoded_dir
)->data
;
2529 if (rmdir (dir
) != 0)
2530 report_file_error ("Removing directory", Flist (1, &directory
));
2535 DEFUN ("delete-file", Fdelete_file
, Sdelete_file
, 1, 1, "fDelete file: ",
2536 doc
: /* Delete file named FILENAME.
2537 If file has multiple names, it continues to exist with the other names. */)
2539 Lisp_Object filename
;
2541 Lisp_Object handler
;
2542 Lisp_Object encoded_file
;
2544 CHECK_STRING (filename
);
2545 filename
= Fexpand_file_name (filename
, Qnil
);
2547 handler
= Ffind_file_name_handler (filename
, Qdelete_file
);
2548 if (!NILP (handler
))
2549 return call2 (handler
, Qdelete_file
, filename
);
2551 encoded_file
= ENCODE_FILE (filename
);
2553 if (0 > unlink (XSTRING (encoded_file
)->data
))
2554 report_file_error ("Removing old name", Flist (1, &filename
));
2559 internal_delete_file_1 (ignore
)
2565 /* Delete file FILENAME, returning 1 if successful and 0 if failed. */
2568 internal_delete_file (filename
)
2569 Lisp_Object filename
;
2571 return NILP (internal_condition_case_1 (Fdelete_file
, filename
,
2572 Qt
, internal_delete_file_1
));
2575 DEFUN ("rename-file", Frename_file
, Srename_file
, 2, 3,
2576 "fRename file: \nFRename %s to file: \np",
2577 doc
: /* Rename FILE as NEWNAME. Both args strings.
2578 If file has names other than FILE, it continues to have those names.
2579 Signals a `file-already-exists' error if a file NEWNAME already exists
2580 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
2581 A number as third arg means request confirmation if NEWNAME already exists.
2582 This is what happens in interactive use with M-x. */)
2583 (file
, newname
, ok_if_already_exists
)
2584 Lisp_Object file
, newname
, ok_if_already_exists
;
2587 Lisp_Object args
[2];
2589 Lisp_Object handler
;
2590 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2591 Lisp_Object encoded_file
, encoded_newname
;
2593 encoded_file
= encoded_newname
= Qnil
;
2594 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2595 CHECK_STRING (file
);
2596 CHECK_STRING (newname
);
2597 file
= Fexpand_file_name (file
, Qnil
);
2598 newname
= Fexpand_file_name (newname
, Qnil
);
2600 /* If the file name has special constructs in it,
2601 call the corresponding file handler. */
2602 handler
= Ffind_file_name_handler (file
, Qrename_file
);
2604 handler
= Ffind_file_name_handler (newname
, Qrename_file
);
2605 if (!NILP (handler
))
2606 RETURN_UNGCPRO (call4 (handler
, Qrename_file
,
2607 file
, newname
, ok_if_already_exists
));
2609 encoded_file
= ENCODE_FILE (file
);
2610 encoded_newname
= ENCODE_FILE (newname
);
2613 /* If the file names are identical but for the case, don't ask for
2614 confirmation: they simply want to change the letter-case of the
2616 if (NILP (Fstring_equal (Fdowncase (file
), Fdowncase (newname
))))
2618 if (NILP (ok_if_already_exists
)
2619 || INTEGERP (ok_if_already_exists
))
2620 barf_or_query_if_file_exists (encoded_newname
, "rename to it",
2621 INTEGERP (ok_if_already_exists
), 0, 0);
2623 if (0 > rename (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
))
2625 if (0 > link (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
)
2626 || 0 > unlink (XSTRING (encoded_file
)->data
))
2631 Fcopy_file (file
, newname
,
2632 /* We have already prompted if it was an integer,
2633 so don't have copy-file prompt again. */
2634 NILP (ok_if_already_exists
) ? Qnil
: Qt
, Qt
);
2635 Fdelete_file (file
);
2642 report_file_error ("Renaming", Flist (2, args
));
2645 report_file_error ("Renaming", Flist (2, &file
));
2652 DEFUN ("add-name-to-file", Fadd_name_to_file
, Sadd_name_to_file
, 2, 3,
2653 "fAdd name to file: \nFName to add to %s: \np",
2654 doc
: /* Give FILE additional name NEWNAME. Both args strings.
2655 Signals a `file-already-exists' error if a file NEWNAME already exists
2656 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
2657 A number as third arg means request confirmation if NEWNAME already exists.
2658 This is what happens in interactive use with M-x. */)
2659 (file
, newname
, ok_if_already_exists
)
2660 Lisp_Object file
, newname
, ok_if_already_exists
;
2663 Lisp_Object args
[2];
2665 Lisp_Object handler
;
2666 Lisp_Object encoded_file
, encoded_newname
;
2667 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2669 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2670 encoded_file
= encoded_newname
= Qnil
;
2671 CHECK_STRING (file
);
2672 CHECK_STRING (newname
);
2673 file
= Fexpand_file_name (file
, Qnil
);
2674 newname
= Fexpand_file_name (newname
, Qnil
);
2676 /* If the file name has special constructs in it,
2677 call the corresponding file handler. */
2678 handler
= Ffind_file_name_handler (file
, Qadd_name_to_file
);
2679 if (!NILP (handler
))
2680 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2681 newname
, ok_if_already_exists
));
2683 /* If the new name has special constructs in it,
2684 call the corresponding file handler. */
2685 handler
= Ffind_file_name_handler (newname
, Qadd_name_to_file
);
2686 if (!NILP (handler
))
2687 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2688 newname
, ok_if_already_exists
));
2690 encoded_file
= ENCODE_FILE (file
);
2691 encoded_newname
= ENCODE_FILE (newname
);
2693 if (NILP (ok_if_already_exists
)
2694 || INTEGERP (ok_if_already_exists
))
2695 barf_or_query_if_file_exists (encoded_newname
, "make it a new name",
2696 INTEGERP (ok_if_already_exists
), 0, 0);
2698 unlink (XSTRING (newname
)->data
);
2699 if (0 > link (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
))
2704 report_file_error ("Adding new name", Flist (2, args
));
2706 report_file_error ("Adding new name", Flist (2, &file
));
2715 DEFUN ("make-symbolic-link", Fmake_symbolic_link
, Smake_symbolic_link
, 2, 3,
2716 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np",
2717 doc
: /* Make a symbolic link to FILENAME, named LINKNAME. Both args strings.
2718 Signals a `file-already-exists' error if a file LINKNAME already exists
2719 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
2720 A number as third arg means request confirmation if LINKNAME already exists.
2721 This happens for interactive use with M-x. */)
2722 (filename
, linkname
, ok_if_already_exists
)
2723 Lisp_Object filename
, linkname
, ok_if_already_exists
;
2726 Lisp_Object args
[2];
2728 Lisp_Object handler
;
2729 Lisp_Object encoded_filename
, encoded_linkname
;
2730 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2732 GCPRO4 (filename
, linkname
, encoded_filename
, encoded_linkname
);
2733 encoded_filename
= encoded_linkname
= Qnil
;
2734 CHECK_STRING (filename
);
2735 CHECK_STRING (linkname
);
2736 /* If the link target has a ~, we must expand it to get
2737 a truly valid file name. Otherwise, do not expand;
2738 we want to permit links to relative file names. */
2739 if (XSTRING (filename
)->data
[0] == '~')
2740 filename
= Fexpand_file_name (filename
, Qnil
);
2741 linkname
= Fexpand_file_name (linkname
, Qnil
);
2743 /* If the file name has special constructs in it,
2744 call the corresponding file handler. */
2745 handler
= Ffind_file_name_handler (filename
, Qmake_symbolic_link
);
2746 if (!NILP (handler
))
2747 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2748 linkname
, ok_if_already_exists
));
2750 /* If the new link name has special constructs in it,
2751 call the corresponding file handler. */
2752 handler
= Ffind_file_name_handler (linkname
, Qmake_symbolic_link
);
2753 if (!NILP (handler
))
2754 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2755 linkname
, ok_if_already_exists
));
2757 encoded_filename
= ENCODE_FILE (filename
);
2758 encoded_linkname
= ENCODE_FILE (linkname
);
2760 if (NILP (ok_if_already_exists
)
2761 || INTEGERP (ok_if_already_exists
))
2762 barf_or_query_if_file_exists (encoded_linkname
, "make it a link",
2763 INTEGERP (ok_if_already_exists
), 0, 0);
2764 if (0 > symlink (XSTRING (encoded_filename
)->data
,
2765 XSTRING (encoded_linkname
)->data
))
2767 /* If we didn't complain already, silently delete existing file. */
2768 if (errno
== EEXIST
)
2770 unlink (XSTRING (encoded_linkname
)->data
);
2771 if (0 <= symlink (XSTRING (encoded_filename
)->data
,
2772 XSTRING (encoded_linkname
)->data
))
2782 report_file_error ("Making symbolic link", Flist (2, args
));
2784 report_file_error ("Making symbolic link", Flist (2, &filename
));
2790 #endif /* S_IFLNK */
2794 DEFUN ("define-logical-name", Fdefine_logical_name
, Sdefine_logical_name
,
2795 2, 2, "sDefine logical name: \nsDefine logical name %s as: ",
2796 doc
: /* Define the job-wide logical name NAME to have the value STRING.
2797 If STRING is nil or a null string, the logical name NAME is deleted. */)
2802 CHECK_STRING (name
);
2804 delete_logical_name (XSTRING (name
)->data
);
2807 CHECK_STRING (string
);
2809 if (XSTRING (string
)->size
== 0)
2810 delete_logical_name (XSTRING (name
)->data
);
2812 define_logical_name (XSTRING (name
)->data
, XSTRING (string
)->data
);
2821 DEFUN ("sysnetunam", Fsysnetunam
, Ssysnetunam
, 2, 2, 0,
2822 doc
: /* Open a network connection to PATH using LOGIN as the login string. */)
2824 Lisp_Object path
, login
;
2828 CHECK_STRING (path
);
2829 CHECK_STRING (login
);
2831 netresult
= netunam (XSTRING (path
)->data
, XSTRING (login
)->data
);
2833 if (netresult
== -1)
2838 #endif /* HPUX_NET */
2840 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p
, Sfile_name_absolute_p
,
2842 doc
: /* Return t if file FILENAME specifies an absolute file name.
2843 On Unix, this is a name starting with a `/' or a `~'. */)
2845 Lisp_Object filename
;
2849 CHECK_STRING (filename
);
2850 ptr
= XSTRING (filename
)->data
;
2851 if (IS_DIRECTORY_SEP (*ptr
) || *ptr
== '~'
2853 /* ??? This criterion is probably wrong for '<'. */
2854 || index (ptr
, ':') || index (ptr
, '<')
2855 || (*ptr
== '[' && (ptr
[1] != '-' || (ptr
[2] != '.' && ptr
[2] != ']'))
2859 || (IS_DRIVE (*ptr
) && ptr
[1] == ':' && IS_DIRECTORY_SEP (ptr
[2]))
2867 /* Return nonzero if file FILENAME exists and can be executed. */
2870 check_executable (filename
)
2874 int len
= strlen (filename
);
2877 if (stat (filename
, &st
) < 0)
2879 #if defined (WINDOWSNT) || (defined (MSDOS) && __DJGPP__ > 1)
2880 return ((st
.st_mode
& S_IEXEC
) != 0);
2882 return (S_ISREG (st
.st_mode
)
2884 && (stricmp ((suffix
= filename
+ len
-4), ".com") == 0
2885 || stricmp (suffix
, ".exe") == 0
2886 || stricmp (suffix
, ".bat") == 0)
2887 || (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2888 #endif /* not WINDOWSNT */
2889 #else /* not DOS_NT */
2890 #ifdef HAVE_EUIDACCESS
2891 return (euidaccess (filename
, 1) >= 0);
2893 /* Access isn't quite right because it uses the real uid
2894 and we really want to test with the effective uid.
2895 But Unix doesn't give us a right way to do it. */
2896 return (access (filename
, 1) >= 0);
2898 #endif /* not DOS_NT */
2901 /* Return nonzero if file FILENAME exists and can be written. */
2904 check_writable (filename
)
2909 if (stat (filename
, &st
) < 0)
2911 return (st
.st_mode
& S_IWRITE
|| (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2912 #else /* not MSDOS */
2913 #ifdef HAVE_EUIDACCESS
2914 return (euidaccess (filename
, 2) >= 0);
2916 /* Access isn't quite right because it uses the real uid
2917 and we really want to test with the effective uid.
2918 But Unix doesn't give us a right way to do it.
2919 Opening with O_WRONLY could work for an ordinary file,
2920 but would lose for directories. */
2921 return (access (filename
, 2) >= 0);
2923 #endif /* not MSDOS */
2926 DEFUN ("file-exists-p", Ffile_exists_p
, Sfile_exists_p
, 1, 1, 0,
2927 doc
: /* Return t if file FILENAME exists. (This does not mean you can read it.)
2928 See also `file-readable-p' and `file-attributes'. */)
2930 Lisp_Object filename
;
2932 Lisp_Object absname
;
2933 Lisp_Object handler
;
2934 struct stat statbuf
;
2936 CHECK_STRING (filename
);
2937 absname
= Fexpand_file_name (filename
, Qnil
);
2939 /* If the file name has special constructs in it,
2940 call the corresponding file handler. */
2941 handler
= Ffind_file_name_handler (absname
, Qfile_exists_p
);
2942 if (!NILP (handler
))
2943 return call2 (handler
, Qfile_exists_p
, absname
);
2945 absname
= ENCODE_FILE (absname
);
2947 return (stat (XSTRING (absname
)->data
, &statbuf
) >= 0) ? Qt
: Qnil
;
2950 DEFUN ("file-executable-p", Ffile_executable_p
, Sfile_executable_p
, 1, 1, 0,
2951 doc
: /* Return t if FILENAME can be executed by you.
2952 For a directory, this means you can access files in that directory. */)
2954 Lisp_Object filename
;
2956 Lisp_Object absname
;
2957 Lisp_Object handler
;
2959 CHECK_STRING (filename
);
2960 absname
= Fexpand_file_name (filename
, Qnil
);
2962 /* If the file name has special constructs in it,
2963 call the corresponding file handler. */
2964 handler
= Ffind_file_name_handler (absname
, Qfile_executable_p
);
2965 if (!NILP (handler
))
2966 return call2 (handler
, Qfile_executable_p
, absname
);
2968 absname
= ENCODE_FILE (absname
);
2970 return (check_executable (XSTRING (absname
)->data
) ? Qt
: Qnil
);
2973 DEFUN ("file-readable-p", Ffile_readable_p
, Sfile_readable_p
, 1, 1, 0,
2974 doc
: /* Return t if file FILENAME exists and you can read it.
2975 See also `file-exists-p' and `file-attributes'. */)
2977 Lisp_Object filename
;
2979 Lisp_Object absname
;
2980 Lisp_Object handler
;
2983 struct stat statbuf
;
2985 CHECK_STRING (filename
);
2986 absname
= Fexpand_file_name (filename
, Qnil
);
2988 /* If the file name has special constructs in it,
2989 call the corresponding file handler. */
2990 handler
= Ffind_file_name_handler (absname
, Qfile_readable_p
);
2991 if (!NILP (handler
))
2992 return call2 (handler
, Qfile_readable_p
, absname
);
2994 absname
= ENCODE_FILE (absname
);
2996 #if defined(DOS_NT) || defined(macintosh)
2997 /* Under MS-DOS, Windows, and Macintosh, open does not work for
2999 if (access (XSTRING (absname
)->data
, 0) == 0)
3002 #else /* not DOS_NT and not macintosh */
3004 #if defined (S_ISFIFO) && defined (O_NONBLOCK)
3005 /* Opening a fifo without O_NONBLOCK can wait.
3006 We don't want to wait. But we don't want to mess wth O_NONBLOCK
3007 except in the case of a fifo, on a system which handles it. */
3008 desc
= stat (XSTRING (absname
)->data
, &statbuf
);
3011 if (S_ISFIFO (statbuf
.st_mode
))
3012 flags
|= O_NONBLOCK
;
3014 desc
= emacs_open (XSTRING (absname
)->data
, flags
, 0);
3019 #endif /* not DOS_NT and not macintosh */
3022 /* Having this before file-symlink-p mysteriously caused it to be forgotten
3024 DEFUN ("file-writable-p", Ffile_writable_p
, Sfile_writable_p
, 1, 1, 0,
3025 doc
: /* Return t if file FILENAME can be written or created by you. */)
3027 Lisp_Object filename
;
3029 Lisp_Object absname
, dir
, encoded
;
3030 Lisp_Object handler
;
3031 struct stat statbuf
;
3033 CHECK_STRING (filename
);
3034 absname
= Fexpand_file_name (filename
, Qnil
);
3036 /* If the file name has special constructs in it,
3037 call the corresponding file handler. */
3038 handler
= Ffind_file_name_handler (absname
, Qfile_writable_p
);
3039 if (!NILP (handler
))
3040 return call2 (handler
, Qfile_writable_p
, absname
);
3042 encoded
= ENCODE_FILE (absname
);
3043 if (stat (XSTRING (encoded
)->data
, &statbuf
) >= 0)
3044 return (check_writable (XSTRING (encoded
)->data
)
3047 dir
= Ffile_name_directory (absname
);
3050 dir
= Fdirectory_file_name (dir
);
3054 dir
= Fdirectory_file_name (dir
);
3057 dir
= ENCODE_FILE (dir
);
3059 /* The read-only attribute of the parent directory doesn't affect
3060 whether a file or directory can be created within it. Some day we
3061 should check ACLs though, which do affect this. */
3062 if (stat (XSTRING (dir
)->data
, &statbuf
) < 0)
3064 return (statbuf
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
3066 return (check_writable (!NILP (dir
) ? (char *) XSTRING (dir
)->data
: "")
3071 DEFUN ("access-file", Faccess_file
, Saccess_file
, 2, 2, 0,
3072 doc
: /* Access file FILENAME, and get an error if that does not work.
3073 The second argument STRING is used in the error message.
3074 If there is no error, we return nil. */)
3076 Lisp_Object filename
, string
;
3078 Lisp_Object handler
, encoded_filename
, absname
;
3081 CHECK_STRING (filename
);
3082 absname
= Fexpand_file_name (filename
, Qnil
);
3084 CHECK_STRING (string
);
3086 /* If the file name has special constructs in it,
3087 call the corresponding file handler. */
3088 handler
= Ffind_file_name_handler (absname
, Qaccess_file
);
3089 if (!NILP (handler
))
3090 return call3 (handler
, Qaccess_file
, absname
, string
);
3092 encoded_filename
= ENCODE_FILE (absname
);
3094 fd
= emacs_open (XSTRING (encoded_filename
)->data
, O_RDONLY
, 0);
3096 report_file_error (XSTRING (string
)->data
, Fcons (filename
, Qnil
));
3102 DEFUN ("file-symlink-p", Ffile_symlink_p
, Sfile_symlink_p
, 1, 1, 0,
3103 doc
: /* Return non-nil if file FILENAME is the name of a symbolic link.
3104 The value is the name of the file to which it is linked.
3105 Otherwise returns nil. */)
3107 Lisp_Object filename
;
3114 Lisp_Object handler
;
3116 CHECK_STRING (filename
);
3117 filename
= Fexpand_file_name (filename
, Qnil
);
3119 /* If the file name has special constructs in it,
3120 call the corresponding file handler. */
3121 handler
= Ffind_file_name_handler (filename
, Qfile_symlink_p
);
3122 if (!NILP (handler
))
3123 return call2 (handler
, Qfile_symlink_p
, filename
);
3125 filename
= ENCODE_FILE (filename
);
3132 buf
= (char *) xrealloc (buf
, bufsize
);
3133 bzero (buf
, bufsize
);
3136 valsize
= readlink (XSTRING (filename
)->data
, buf
, bufsize
);
3140 /* HP-UX reports ERANGE if buffer is too small. */
3141 if (errno
== ERANGE
)
3151 while (valsize
>= bufsize
);
3153 val
= make_string (buf
, valsize
);
3154 if (buf
[0] == '/' && index (buf
, ':'))
3155 val
= concat2 (build_string ("/:"), val
);
3157 val
= DECODE_FILE (val
);
3159 #else /* not S_IFLNK */
3161 #endif /* not S_IFLNK */
3164 DEFUN ("file-directory-p", Ffile_directory_p
, Sfile_directory_p
, 1, 1, 0,
3165 doc
: /* Return t if FILENAME names an existing directory.
3166 Symbolic links to directories count as directories.
3167 See `file-symlink-p' to distinguish symlinks. */)
3169 Lisp_Object filename
;
3171 register Lisp_Object absname
;
3173 Lisp_Object handler
;
3175 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
3177 /* If the file name has special constructs in it,
3178 call the corresponding file handler. */
3179 handler
= Ffind_file_name_handler (absname
, Qfile_directory_p
);
3180 if (!NILP (handler
))
3181 return call2 (handler
, Qfile_directory_p
, absname
);
3183 absname
= ENCODE_FILE (absname
);
3185 if (stat (XSTRING (absname
)->data
, &st
) < 0)
3187 return (st
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
3190 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p
, Sfile_accessible_directory_p
, 1, 1, 0,
3191 doc
: /* Return t if file FILENAME names a directory you can open.
3192 For the value to be t, FILENAME must specify the name of a directory as a file,
3193 and the directory must allow you to open files in it. In order to use a
3194 directory as a buffer's current directory, this predicate must return true.
3195 A directory name spec may be given instead; then the value is t
3196 if the directory so specified exists and really is a readable and
3197 searchable directory. */)
3199 Lisp_Object filename
;
3201 Lisp_Object handler
;
3203 struct gcpro gcpro1
;
3205 /* If the file name has special constructs in it,
3206 call the corresponding file handler. */
3207 handler
= Ffind_file_name_handler (filename
, Qfile_accessible_directory_p
);
3208 if (!NILP (handler
))
3209 return call2 (handler
, Qfile_accessible_directory_p
, filename
);
3211 /* It's an unlikely combination, but yes we really do need to gcpro:
3212 Suppose that file-accessible-directory-p has no handler, but
3213 file-directory-p does have a handler; this handler causes a GC which
3214 relocates the string in `filename'; and finally file-directory-p
3215 returns non-nil. Then we would end up passing a garbaged string
3216 to file-executable-p. */
3218 tem
= (NILP (Ffile_directory_p (filename
))
3219 || NILP (Ffile_executable_p (filename
)));
3221 return tem
? Qnil
: Qt
;
3224 DEFUN ("file-regular-p", Ffile_regular_p
, Sfile_regular_p
, 1, 1, 0,
3225 doc
: /* Return t if file FILENAME is the name of a regular file.
3226 This is the sort of file that holds an ordinary stream of data bytes. */)
3228 Lisp_Object filename
;
3230 register Lisp_Object absname
;
3232 Lisp_Object handler
;
3234 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
3236 /* If the file name has special constructs in it,
3237 call the corresponding file handler. */
3238 handler
= Ffind_file_name_handler (absname
, Qfile_regular_p
);
3239 if (!NILP (handler
))
3240 return call2 (handler
, Qfile_regular_p
, absname
);
3242 absname
= ENCODE_FILE (absname
);
3247 Lisp_Object tem
= Vw32_get_true_file_attributes
;
3249 /* Tell stat to use expensive method to get accurate info. */
3250 Vw32_get_true_file_attributes
= Qt
;
3251 result
= stat (XSTRING (absname
)->data
, &st
);
3252 Vw32_get_true_file_attributes
= tem
;
3256 return (st
.st_mode
& S_IFMT
) == S_IFREG
? Qt
: Qnil
;
3259 if (stat (XSTRING (absname
)->data
, &st
) < 0)
3261 return (st
.st_mode
& S_IFMT
) == S_IFREG
? Qt
: Qnil
;
3265 DEFUN ("file-modes", Ffile_modes
, Sfile_modes
, 1, 1, 0,
3266 doc
: /* Return mode bits of file named FILENAME, as an integer. */)
3268 Lisp_Object filename
;
3270 Lisp_Object absname
;
3272 Lisp_Object handler
;
3274 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
3276 /* If the file name has special constructs in it,
3277 call the corresponding file handler. */
3278 handler
= Ffind_file_name_handler (absname
, Qfile_modes
);
3279 if (!NILP (handler
))
3280 return call2 (handler
, Qfile_modes
, absname
);
3282 absname
= ENCODE_FILE (absname
);
3284 if (stat (XSTRING (absname
)->data
, &st
) < 0)
3286 #if defined (MSDOS) && __DJGPP__ < 2
3287 if (check_executable (XSTRING (absname
)->data
))
3288 st
.st_mode
|= S_IEXEC
;
3289 #endif /* MSDOS && __DJGPP__ < 2 */
3291 return make_number (st
.st_mode
& 07777);
3294 DEFUN ("set-file-modes", Fset_file_modes
, Sset_file_modes
, 2, 2, 0,
3295 doc
: /* Set mode bits of file named FILENAME to MODE (an integer).
3296 Only the 12 low bits of MODE are used. */)
3298 Lisp_Object filename
, mode
;
3300 Lisp_Object absname
, encoded_absname
;
3301 Lisp_Object handler
;
3303 absname
= Fexpand_file_name (filename
, current_buffer
->directory
);
3304 CHECK_NUMBER (mode
);
3306 /* If the file name has special constructs in it,
3307 call the corresponding file handler. */
3308 handler
= Ffind_file_name_handler (absname
, Qset_file_modes
);
3309 if (!NILP (handler
))
3310 return call3 (handler
, Qset_file_modes
, absname
, mode
);
3312 encoded_absname
= ENCODE_FILE (absname
);
3314 if (chmod (XSTRING (encoded_absname
)->data
, XINT (mode
)) < 0)
3315 report_file_error ("Doing chmod", Fcons (absname
, Qnil
));
3320 DEFUN ("set-default-file-modes", Fset_default_file_modes
, Sset_default_file_modes
, 1, 1, 0,
3321 doc
: /* Set the file permission bits for newly created files.
3322 The argument MODE should be an integer; only the low 9 bits are used.
3323 This setting is inherited by subprocesses. */)
3327 CHECK_NUMBER (mode
);
3329 umask ((~ XINT (mode
)) & 0777);
3334 DEFUN ("default-file-modes", Fdefault_file_modes
, Sdefault_file_modes
, 0, 0, 0,
3335 doc
: /* Return the default file protection for created files.
3336 The value is an integer. */)
3342 realmask
= umask (0);
3345 XSETINT (value
, (~ realmask
) & 0777);
3355 DEFUN ("unix-sync", Funix_sync
, Sunix_sync
, 0, 0, "",
3356 doc
: /* Tell Unix to finish all pending disk updates. */)
3365 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p
, Sfile_newer_than_file_p
, 2, 2, 0,
3366 doc
: /* Return t if file FILE1 is newer than file FILE2.
3367 If FILE1 does not exist, the answer is nil;
3368 otherwise, if FILE2 does not exist, the answer is t. */)
3370 Lisp_Object file1
, file2
;
3372 Lisp_Object absname1
, absname2
;
3375 Lisp_Object handler
;
3376 struct gcpro gcpro1
, gcpro2
;
3378 CHECK_STRING (file1
);
3379 CHECK_STRING (file2
);
3382 GCPRO2 (absname1
, file2
);
3383 absname1
= expand_and_dir_to_file (file1
, current_buffer
->directory
);
3384 absname2
= expand_and_dir_to_file (file2
, current_buffer
->directory
);
3387 /* If the file name has special constructs in it,
3388 call the corresponding file handler. */
3389 handler
= Ffind_file_name_handler (absname1
, Qfile_newer_than_file_p
);
3391 handler
= Ffind_file_name_handler (absname2
, Qfile_newer_than_file_p
);
3392 if (!NILP (handler
))
3393 return call3 (handler
, Qfile_newer_than_file_p
, absname1
, absname2
);
3395 GCPRO2 (absname1
, absname2
);
3396 absname1
= ENCODE_FILE (absname1
);
3397 absname2
= ENCODE_FILE (absname2
);
3400 if (stat (XSTRING (absname1
)->data
, &st
) < 0)
3403 mtime1
= st
.st_mtime
;
3405 if (stat (XSTRING (absname2
)->data
, &st
) < 0)
3408 return (mtime1
> st
.st_mtime
) ? Qt
: Qnil
;
3412 Lisp_Object Qfind_buffer_file_type
;
3415 #ifndef READ_BUF_SIZE
3416 #define READ_BUF_SIZE (64 << 10)
3419 extern void adjust_markers_for_delete
P_ ((int, int, int, int));
3421 /* This function is called after Lisp functions to decide a coding
3422 system are called, or when they cause an error. Before they are
3423 called, the current buffer is set unibyte and it contains only a
3424 newly inserted text (thus the buffer was empty before the
3427 The functions may set markers, overlays, text properties, or even
3428 alter the buffer contents, change the current buffer.
3430 Here, we reset all those changes by:
3431 o set back the current buffer.
3432 o move all markers and overlays to BEG.
3433 o remove all text properties.
3434 o set back the buffer multibyteness. */
3437 decide_coding_unwind (unwind_data
)
3438 Lisp_Object unwind_data
;
3440 Lisp_Object multibyte
, undo_list
, buffer
;
3442 multibyte
= XCAR (unwind_data
);
3443 unwind_data
= XCDR (unwind_data
);
3444 undo_list
= XCAR (unwind_data
);
3445 buffer
= XCDR (unwind_data
);
3447 if (current_buffer
!= XBUFFER (buffer
))
3448 set_buffer_internal (XBUFFER (buffer
));
3449 adjust_markers_for_delete (BEG
, BEG_BYTE
, Z
, Z_BYTE
);
3450 adjust_overlays_for_delete (BEG
, Z
- BEG
);
3451 BUF_INTERVALS (current_buffer
) = 0;
3452 TEMP_SET_PT_BOTH (BEG
, BEG_BYTE
);
3454 /* Now we are safe to change the buffer's multibyteness directly. */
3455 current_buffer
->enable_multibyte_characters
= multibyte
;
3456 current_buffer
->undo_list
= undo_list
;
3462 /* Used to pass values from insert-file-contents to read_non_regular. */
3464 static int non_regular_fd
;
3465 static int non_regular_inserted
;
3466 static int non_regular_nbytes
;
3469 /* Read from a non-regular file.
3470 Read non_regular_trytry bytes max from non_regular_fd.
3471 Non_regular_inserted specifies where to put the read bytes.
3472 Value is the number of bytes read. */
3481 nbytes
= emacs_read (non_regular_fd
,
3482 BEG_ADDR
+ PT_BYTE
- 1 + non_regular_inserted
,
3483 non_regular_nbytes
);
3484 Fsignal (Qquit
, Qnil
);
3486 return make_number (nbytes
);
3490 /* Condition-case handler used when reading from non-regular files
3491 in insert-file-contents. */
3494 read_non_regular_quit ()
3500 DEFUN ("insert-file-contents", Finsert_file_contents
, Sinsert_file_contents
,
3502 doc
: /* Insert contents of file FILENAME after point.
3503 Returns list of absolute file name and number of bytes inserted.
3504 If second argument VISIT is non-nil, the buffer's visited filename
3505 and last save file modtime are set, and it is marked unmodified.
3506 If visiting and the file does not exist, visiting is completed
3507 before the error is signaled.
3508 The optional third and fourth arguments BEG and END
3509 specify what portion of the file to insert.
3510 These arguments count bytes in the file, not characters in the buffer.
3511 If VISIT is non-nil, BEG and END must be nil.
3513 If optional fifth argument REPLACE is non-nil,
3514 it means replace the current buffer contents (in the accessible portion)
3515 with the file contents. This is better than simply deleting and inserting
3516 the whole thing because (1) it preserves some marker positions
3517 and (2) it puts less data in the undo list.
3518 When REPLACE is non-nil, the value is the number of characters actually read,
3519 which is often less than the number of characters to be read.
3521 This does code conversion according to the value of
3522 `coding-system-for-read' or `file-coding-system-alist',
3523 and sets the variable `last-coding-system-used' to the coding system
3525 (filename
, visit
, beg
, end
, replace
)
3526 Lisp_Object filename
, visit
, beg
, end
, replace
;
3531 register int how_much
;
3532 register int unprocessed
;
3533 int count
= BINDING_STACK_SIZE ();
3534 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
3535 Lisp_Object handler
, val
, insval
, orig_filename
;
3538 int not_regular
= 0;
3539 unsigned char read_buf
[READ_BUF_SIZE
];
3540 struct coding_system coding
;
3541 unsigned char buffer
[1 << 14];
3542 int replace_handled
= 0;
3543 int set_coding_system
= 0;
3544 int coding_system_decided
= 0;
3547 if (current_buffer
->base_buffer
&& ! NILP (visit
))
3548 error ("Cannot do file visiting in an indirect buffer");
3550 if (!NILP (current_buffer
->read_only
))
3551 Fbarf_if_buffer_read_only ();
3555 orig_filename
= Qnil
;
3557 GCPRO4 (filename
, val
, p
, orig_filename
);
3559 CHECK_STRING (filename
);
3560 filename
= Fexpand_file_name (filename
, Qnil
);
3562 /* If the file name has special constructs in it,
3563 call the corresponding file handler. */
3564 handler
= Ffind_file_name_handler (filename
, Qinsert_file_contents
);
3565 if (!NILP (handler
))
3567 val
= call6 (handler
, Qinsert_file_contents
, filename
,
3568 visit
, beg
, end
, replace
);
3569 if (CONSP (val
) && CONSP (XCDR (val
)))
3570 inserted
= XINT (XCAR (XCDR (val
)));
3574 orig_filename
= filename
;
3575 filename
= ENCODE_FILE (filename
);
3581 Lisp_Object tem
= Vw32_get_true_file_attributes
;
3583 /* Tell stat to use expensive method to get accurate info. */
3584 Vw32_get_true_file_attributes
= Qt
;
3585 total
= stat (XSTRING (filename
)->data
, &st
);
3586 Vw32_get_true_file_attributes
= tem
;
3591 if (stat (XSTRING (filename
)->data
, &st
) < 0)
3593 if ((fd
= emacs_open (XSTRING (filename
)->data
, O_RDONLY
, 0)) < 0
3594 || fstat (fd
, &st
) < 0)
3595 #endif /* not APOLLO */
3596 #endif /* WINDOWSNT */
3598 if (fd
>= 0) emacs_close (fd
);
3601 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
3604 if (!NILP (Vcoding_system_for_read
))
3605 Fset (Qbuffer_file_coding_system
, Vcoding_system_for_read
);
3610 /* This code will need to be changed in order to work on named
3611 pipes, and it's probably just not worth it. So we should at
3612 least signal an error. */
3613 if (!S_ISREG (st
.st_mode
))
3620 if (! NILP (replace
) || ! NILP (beg
) || ! NILP (end
))
3621 Fsignal (Qfile_error
,
3622 Fcons (build_string ("not a regular file"),
3623 Fcons (orig_filename
, Qnil
)));
3628 if ((fd
= emacs_open (XSTRING (filename
)->data
, O_RDONLY
, 0)) < 0)
3631 /* Replacement should preserve point as it preserves markers. */
3632 if (!NILP (replace
))
3633 record_unwind_protect (restore_point_unwind
, Fpoint_marker ());
3635 record_unwind_protect (close_file_unwind
, make_number (fd
));
3637 /* Supposedly happens on VMS. */
3638 if (! not_regular
&& st
.st_size
< 0)
3639 error ("File size is negative");
3641 /* Prevent redisplay optimizations. */
3642 current_buffer
->clip_changed
= 1;
3646 if (!NILP (beg
) || !NILP (end
))
3647 error ("Attempt to visit less than an entire file");
3648 if (BEG
< Z
&& NILP (replace
))
3649 error ("Cannot do file visiting in a non-empty buffer");
3655 XSETFASTINT (beg
, 0);
3663 XSETINT (end
, st
.st_size
);
3665 /* Arithmetic overflow can occur if an Emacs integer cannot
3666 represent the file size, or if the calculations below
3667 overflow. The calculations below double the file size
3668 twice, so check that it can be multiplied by 4 safely. */
3669 if (XINT (end
) != st
.st_size
3670 || ((int) st
.st_size
* 4) / 4 != st
.st_size
)
3671 error ("Maximum buffer size exceeded");
3673 /* The file size returned from stat may be zero, but data
3674 may be readable nonetheless, for example when this is a
3675 file in the /proc filesystem. */
3676 if (st
.st_size
== 0)
3677 XSETINT (end
, READ_BUF_SIZE
);
3683 /* Decide the coding system to use for reading the file now
3684 because we can't use an optimized method for handling
3685 `coding:' tag if the current buffer is not empty. */
3689 if (!NILP (Vcoding_system_for_read
))
3690 val
= Vcoding_system_for_read
;
3691 else if (! NILP (replace
))
3692 /* In REPLACE mode, we can use the same coding system
3693 that was used to visit the file. */
3694 val
= current_buffer
->buffer_file_coding_system
;
3697 /* Don't try looking inside a file for a coding system
3698 specification if it is not seekable. */
3699 if (! not_regular
&& ! NILP (Vset_auto_coding_function
))
3701 /* Find a coding system specified in the heading two
3702 lines or in the tailing several lines of the file.
3703 We assume that the 1K-byte and 3K-byte for heading
3704 and tailing respectively are sufficient for this
3708 if (st
.st_size
<= (1024 * 4))
3709 nread
= emacs_read (fd
, read_buf
, 1024 * 4);
3712 nread
= emacs_read (fd
, read_buf
, 1024);
3715 if (lseek (fd
, st
.st_size
- (1024 * 3), 0) < 0)
3716 report_file_error ("Setting file position",
3717 Fcons (orig_filename
, Qnil
));
3718 nread
+= emacs_read (fd
, read_buf
+ nread
, 1024 * 3);
3723 error ("IO error reading %s: %s",
3724 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
3727 struct buffer
*prev
= current_buffer
;
3730 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
3732 /* The call to temp_output_buffer_setup binds
3734 count1
= specpdl_ptr
- specpdl
;
3735 temp_output_buffer_setup (" *code-converting-work*");
3737 set_buffer_internal (XBUFFER (Vstandard_output
));
3738 current_buffer
->enable_multibyte_characters
= Qnil
;
3739 insert_1_both (read_buf
, nread
, nread
, 0, 0, 0);
3740 TEMP_SET_PT_BOTH (BEG
, BEG_BYTE
);
3741 val
= call2 (Vset_auto_coding_function
,
3742 filename
, make_number (nread
));
3743 set_buffer_internal (prev
);
3745 /* Remove the binding for standard-output. */
3746 unbind_to (count1
, Qnil
);
3748 /* Discard the unwind protect for recovering the
3752 /* Rewind the file for the actual read done later. */
3753 if (lseek (fd
, 0, 0) < 0)
3754 report_file_error ("Setting file position",
3755 Fcons (orig_filename
, Qnil
));
3761 /* If we have not yet decided a coding system, check
3762 file-coding-system-alist. */
3763 Lisp_Object args
[6], coding_systems
;
3765 args
[0] = Qinsert_file_contents
, args
[1] = orig_filename
;
3766 args
[2] = visit
, args
[3] = beg
, args
[4] = end
, args
[5] = replace
;
3767 coding_systems
= Ffind_operation_coding_system (6, args
);
3768 if (CONSP (coding_systems
))
3769 val
= XCAR (coding_systems
);
3773 setup_coding_system (Fcheck_coding_system (val
), &coding
);
3774 /* Ensure we set Vlast_coding_system_used. */
3775 set_coding_system
= 1;
3777 if (NILP (current_buffer
->enable_multibyte_characters
)
3779 /* We must suppress all character code conversion except for
3780 end-of-line conversion. */
3781 setup_raw_text_coding_system (&coding
);
3783 coding
.src_multibyte
= 0;
3784 coding
.dst_multibyte
3785 = !NILP (current_buffer
->enable_multibyte_characters
);
3786 coding_system_decided
= 1;
3789 /* If requested, replace the accessible part of the buffer
3790 with the file contents. Avoid replacing text at the
3791 beginning or end of the buffer that matches the file contents;
3792 that preserves markers pointing to the unchanged parts.
3794 Here we implement this feature in an optimized way
3795 for the case where code conversion is NOT needed.
3796 The following if-statement handles the case of conversion
3797 in a less optimal way.
3799 If the code conversion is "automatic" then we try using this
3800 method and hope for the best.
3801 But if we discover the need for conversion, we give up on this method
3802 and let the following if-statement handle the replace job. */
3805 && !(coding
.common_flags
& CODING_REQUIRE_DECODING_MASK
))
3807 /* same_at_start and same_at_end count bytes,
3808 because file access counts bytes
3809 and BEG and END count bytes. */
3810 int same_at_start
= BEGV_BYTE
;
3811 int same_at_end
= ZV_BYTE
;
3813 /* There is still a possibility we will find the need to do code
3814 conversion. If that happens, we set this variable to 1 to
3815 give up on handling REPLACE in the optimized way. */
3816 int giveup_match_end
= 0;
3818 if (XINT (beg
) != 0)
3820 if (lseek (fd
, XINT (beg
), 0) < 0)
3821 report_file_error ("Setting file position",
3822 Fcons (orig_filename
, Qnil
));
3827 /* Count how many chars at the start of the file
3828 match the text at the beginning of the buffer. */
3833 nread
= emacs_read (fd
, buffer
, sizeof buffer
);
3835 error ("IO error reading %s: %s",
3836 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
3837 else if (nread
== 0)
3840 if (coding
.type
== coding_type_undecided
)
3841 detect_coding (&coding
, buffer
, nread
);
3842 if (coding
.common_flags
& CODING_REQUIRE_DECODING_MASK
)
3843 /* We found that the file should be decoded somehow.
3844 Let's give up here. */
3846 giveup_match_end
= 1;
3850 if (coding
.eol_type
== CODING_EOL_UNDECIDED
)
3851 detect_eol (&coding
, buffer
, nread
);
3852 if (coding
.eol_type
!= CODING_EOL_UNDECIDED
3853 && coding
.eol_type
!= CODING_EOL_LF
)
3854 /* We found that the format of eol should be decoded.
3855 Let's give up here. */
3857 giveup_match_end
= 1;
3862 while (bufpos
< nread
&& same_at_start
< ZV_BYTE
3863 && FETCH_BYTE (same_at_start
) == buffer
[bufpos
])
3864 same_at_start
++, bufpos
++;
3865 /* If we found a discrepancy, stop the scan.
3866 Otherwise loop around and scan the next bufferful. */
3867 if (bufpos
!= nread
)
3871 /* If the file matches the buffer completely,
3872 there's no need to replace anything. */
3873 if (same_at_start
- BEGV_BYTE
== XINT (end
))
3877 /* Truncate the buffer to the size of the file. */
3878 del_range_1 (same_at_start
, same_at_end
, 0, 0);
3883 /* Count how many chars at the end of the file
3884 match the text at the end of the buffer. But, if we have
3885 already found that decoding is necessary, don't waste time. */
3886 while (!giveup_match_end
)
3888 int total_read
, nread
, bufpos
, curpos
, trial
;
3890 /* At what file position are we now scanning? */
3891 curpos
= XINT (end
) - (ZV_BYTE
- same_at_end
);
3892 /* If the entire file matches the buffer tail, stop the scan. */
3895 /* How much can we scan in the next step? */
3896 trial
= min (curpos
, sizeof buffer
);
3897 if (lseek (fd
, curpos
- trial
, 0) < 0)
3898 report_file_error ("Setting file position",
3899 Fcons (orig_filename
, Qnil
));
3901 total_read
= nread
= 0;
3902 while (total_read
< trial
)
3904 nread
= emacs_read (fd
, buffer
+ total_read
, trial
- total_read
);
3906 error ("IO error reading %s: %s",
3907 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
3908 else if (nread
== 0)
3910 total_read
+= nread
;
3913 /* Scan this bufferful from the end, comparing with
3914 the Emacs buffer. */
3915 bufpos
= total_read
;
3917 /* Compare with same_at_start to avoid counting some buffer text
3918 as matching both at the file's beginning and at the end. */
3919 while (bufpos
> 0 && same_at_end
> same_at_start
3920 && FETCH_BYTE (same_at_end
- 1) == buffer
[bufpos
- 1])
3921 same_at_end
--, bufpos
--;
3923 /* If we found a discrepancy, stop the scan.
3924 Otherwise loop around and scan the preceding bufferful. */
3927 /* If this discrepancy is because of code conversion,
3928 we cannot use this method; giveup and try the other. */
3929 if (same_at_end
> same_at_start
3930 && FETCH_BYTE (same_at_end
- 1) >= 0200
3931 && ! NILP (current_buffer
->enable_multibyte_characters
)
3932 && (CODING_MAY_REQUIRE_DECODING (&coding
)))
3933 giveup_match_end
= 1;
3942 if (! giveup_match_end
)
3946 /* We win! We can handle REPLACE the optimized way. */
3948 /* Extend the start of non-matching text area to multibyte
3949 character boundary. */
3950 if (! NILP (current_buffer
->enable_multibyte_characters
))
3951 while (same_at_start
> BEGV_BYTE
3952 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_start
)))
3955 /* Extend the end of non-matching text area to multibyte
3956 character boundary. */
3957 if (! NILP (current_buffer
->enable_multibyte_characters
))
3958 while (same_at_end
< ZV_BYTE
3959 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_end
)))
3962 /* Don't try to reuse the same piece of text twice. */
3963 overlap
= (same_at_start
- BEGV_BYTE
3964 - (same_at_end
+ st
.st_size
- ZV
));
3966 same_at_end
+= overlap
;
3968 /* Arrange to read only the nonmatching middle part of the file. */
3969 XSETFASTINT (beg
, XINT (beg
) + (same_at_start
- BEGV_BYTE
));
3970 XSETFASTINT (end
, XINT (end
) - (ZV_BYTE
- same_at_end
));
3972 del_range_byte (same_at_start
, same_at_end
, 0);
3973 /* Insert from the file at the proper position. */
3974 temp
= BYTE_TO_CHAR (same_at_start
);
3975 SET_PT_BOTH (temp
, same_at_start
);
3977 /* If display currently starts at beginning of line,
3978 keep it that way. */
3979 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3980 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3982 replace_handled
= 1;
3986 /* If requested, replace the accessible part of the buffer
3987 with the file contents. Avoid replacing text at the
3988 beginning or end of the buffer that matches the file contents;
3989 that preserves markers pointing to the unchanged parts.
3991 Here we implement this feature for the case where code conversion
3992 is needed, in a simple way that needs a lot of memory.
3993 The preceding if-statement handles the case of no conversion
3994 in a more optimized way. */
3995 if (!NILP (replace
) && ! replace_handled
&& BEGV
< ZV
)
3997 int same_at_start
= BEGV_BYTE
;
3998 int same_at_end
= ZV_BYTE
;
4001 /* Make sure that the gap is large enough. */
4002 int bufsize
= 2 * st
.st_size
;
4003 unsigned char *conversion_buffer
= (unsigned char *) xmalloc (bufsize
);
4006 /* First read the whole file, performing code conversion into
4007 CONVERSION_BUFFER. */
4009 if (lseek (fd
, XINT (beg
), 0) < 0)
4011 xfree (conversion_buffer
);
4012 report_file_error ("Setting file position",
4013 Fcons (orig_filename
, Qnil
));
4016 total
= st
.st_size
; /* Total bytes in the file. */
4017 how_much
= 0; /* Bytes read from file so far. */
4018 inserted
= 0; /* Bytes put into CONVERSION_BUFFER so far. */
4019 unprocessed
= 0; /* Bytes not processed in previous loop. */
4021 while (how_much
< total
)
4023 /* try is reserved in some compilers (Microsoft C) */
4024 int trytry
= min (total
- how_much
, READ_BUF_SIZE
- unprocessed
);
4025 unsigned char *destination
= read_buf
+ unprocessed
;
4028 /* Allow quitting out of the actual I/O. */
4031 this = emacs_read (fd
, destination
, trytry
);
4034 if (this < 0 || this + unprocessed
== 0)
4042 if (CODING_MAY_REQUIRE_DECODING (&coding
))
4044 int require
, result
;
4046 this += unprocessed
;
4048 /* If we are using more space than estimated,
4049 make CONVERSION_BUFFER bigger. */
4050 require
= decoding_buffer_size (&coding
, this);
4051 if (inserted
+ require
+ 2 * (total
- how_much
) > bufsize
)
4053 bufsize
= inserted
+ require
+ 2 * (total
- how_much
);
4054 conversion_buffer
= (unsigned char *) xrealloc (conversion_buffer
, bufsize
);
4057 /* Convert this batch with results in CONVERSION_BUFFER. */
4058 if (how_much
>= total
) /* This is the last block. */
4059 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4060 if (coding
.composing
!= COMPOSITION_DISABLED
)
4061 coding_allocate_composition_data (&coding
, BEGV
);
4062 result
= decode_coding (&coding
, read_buf
,
4063 conversion_buffer
+ inserted
,
4064 this, bufsize
- inserted
);
4066 /* Save for next iteration whatever we didn't convert. */
4067 unprocessed
= this - coding
.consumed
;
4068 bcopy (read_buf
+ coding
.consumed
, read_buf
, unprocessed
);
4069 if (!NILP (current_buffer
->enable_multibyte_characters
))
4070 this = coding
.produced
;
4072 this = str_as_unibyte (conversion_buffer
+ inserted
,
4079 /* At this point, INSERTED is how many characters (i.e. bytes)
4080 are present in CONVERSION_BUFFER.
4081 HOW_MUCH should equal TOTAL,
4082 or should be <= 0 if we couldn't read the file. */
4086 xfree (conversion_buffer
);
4089 error ("IO error reading %s: %s",
4090 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
4091 else if (how_much
== -2)
4092 error ("maximum buffer size exceeded");
4095 /* Compare the beginning of the converted file
4096 with the buffer text. */
4099 while (bufpos
< inserted
&& same_at_start
< same_at_end
4100 && FETCH_BYTE (same_at_start
) == conversion_buffer
[bufpos
])
4101 same_at_start
++, bufpos
++;
4103 /* If the file matches the buffer completely,
4104 there's no need to replace anything. */
4106 if (bufpos
== inserted
)
4108 xfree (conversion_buffer
);
4111 /* Truncate the buffer to the size of the file. */
4112 del_range_byte (same_at_start
, same_at_end
, 0);
4117 /* Extend the start of non-matching text area to multibyte
4118 character boundary. */
4119 if (! NILP (current_buffer
->enable_multibyte_characters
))
4120 while (same_at_start
> BEGV_BYTE
4121 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_start
)))
4124 /* Scan this bufferful from the end, comparing with
4125 the Emacs buffer. */
4128 /* Compare with same_at_start to avoid counting some buffer text
4129 as matching both at the file's beginning and at the end. */
4130 while (bufpos
> 0 && same_at_end
> same_at_start
4131 && FETCH_BYTE (same_at_end
- 1) == conversion_buffer
[bufpos
- 1])
4132 same_at_end
--, bufpos
--;
4134 /* Extend the end of non-matching text area to multibyte
4135 character boundary. */
4136 if (! NILP (current_buffer
->enable_multibyte_characters
))
4137 while (same_at_end
< ZV_BYTE
4138 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_end
)))
4141 /* Don't try to reuse the same piece of text twice. */
4142 overlap
= same_at_start
- BEGV_BYTE
- (same_at_end
+ inserted
- ZV_BYTE
);
4144 same_at_end
+= overlap
;
4146 /* If display currently starts at beginning of line,
4147 keep it that way. */
4148 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
4149 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
4151 /* Replace the chars that we need to replace,
4152 and update INSERTED to equal the number of bytes
4153 we are taking from the file. */
4154 inserted
-= (Z_BYTE
- same_at_end
) + (same_at_start
- BEG_BYTE
);
4156 if (same_at_end
!= same_at_start
)
4158 del_range_byte (same_at_start
, same_at_end
, 0);
4160 same_at_start
= GPT_BYTE
;
4164 temp
= BYTE_TO_CHAR (same_at_start
);
4166 /* Insert from the file at the proper position. */
4167 SET_PT_BOTH (temp
, same_at_start
);
4168 insert_1 (conversion_buffer
+ same_at_start
- BEG_BYTE
, inserted
,
4170 if (coding
.cmp_data
&& coding
.cmp_data
->used
)
4171 coding_restore_composition (&coding
, Fcurrent_buffer ());
4172 coding_free_composition_data (&coding
);
4174 /* Set `inserted' to the number of inserted characters. */
4175 inserted
= PT
- temp
;
4177 xfree (conversion_buffer
);
4186 register Lisp_Object temp
;
4188 total
= XINT (end
) - XINT (beg
);
4190 /* Make sure point-max won't overflow after this insertion. */
4191 XSETINT (temp
, total
);
4192 if (total
!= XINT (temp
))
4193 error ("Maximum buffer size exceeded");
4196 /* For a special file, all we can do is guess. */
4197 total
= READ_BUF_SIZE
;
4199 if (NILP (visit
) && total
> 0)
4200 prepare_to_modify_buffer (PT
, PT
, NULL
);
4203 if (GAP_SIZE
< total
)
4204 make_gap (total
- GAP_SIZE
);
4206 if (XINT (beg
) != 0 || !NILP (replace
))
4208 if (lseek (fd
, XINT (beg
), 0) < 0)
4209 report_file_error ("Setting file position",
4210 Fcons (orig_filename
, Qnil
));
4213 /* In the following loop, HOW_MUCH contains the total bytes read so
4214 far for a regular file, and not changed for a special file. But,
4215 before exiting the loop, it is set to a negative value if I/O
4219 /* Total bytes inserted. */
4222 /* Here, we don't do code conversion in the loop. It is done by
4223 code_convert_region after all data are read into the buffer. */
4225 int gap_size
= GAP_SIZE
;
4227 while (how_much
< total
)
4229 /* try is reserved in some compilers (Microsoft C) */
4230 int trytry
= min (total
- how_much
, READ_BUF_SIZE
);
4237 /* Maybe make more room. */
4238 if (gap_size
< trytry
)
4240 make_gap (total
- gap_size
);
4241 gap_size
= GAP_SIZE
;
4244 /* Read from the file, capturing `quit'. When an
4245 error occurs, end the loop, and arrange for a quit
4246 to be signaled after decoding the text we read. */
4247 non_regular_fd
= fd
;
4248 non_regular_inserted
= inserted
;
4249 non_regular_nbytes
= trytry
;
4250 val
= internal_condition_case_1 (read_non_regular
, Qnil
, Qerror
,
4251 read_non_regular_quit
);
4262 /* Allow quitting out of the actual I/O. We don't make text
4263 part of the buffer until all the reading is done, so a C-g
4264 here doesn't do any harm. */
4267 this = emacs_read (fd
, BEG_ADDR
+ PT_BYTE
- 1 + inserted
, trytry
);
4279 /* For a regular file, where TOTAL is the real size,
4280 count HOW_MUCH to compare with it.
4281 For a special file, where TOTAL is just a buffer size,
4282 so don't bother counting in HOW_MUCH.
4283 (INSERTED is where we count the number of characters inserted.) */
4290 /* Make the text read part of the buffer. */
4291 GAP_SIZE
-= inserted
;
4293 GPT_BYTE
+= inserted
;
4295 ZV_BYTE
+= inserted
;
4300 /* Put an anchor to ensure multi-byte form ends at gap. */
4305 /* Discard the unwind protect for closing the file. */
4309 error ("IO error reading %s: %s",
4310 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
4314 if (! coding_system_decided
)
4316 /* The coding system is not yet decided. Decide it by an
4317 optimized method for handling `coding:' tag.
4319 Note that we can get here only if the buffer was empty
4320 before the insertion. */
4324 if (!NILP (Vcoding_system_for_read
))
4325 val
= Vcoding_system_for_read
;
4328 /* Since we are sure that the current buffer was empty
4329 before the insertion, we can toggle
4330 enable-multibyte-characters directly here without taking
4331 care of marker adjustment and byte combining problem. By
4332 this way, we can run Lisp program safely before decoding
4333 the inserted text. */
4334 Lisp_Object unwind_data
;
4335 int count
= specpdl_ptr
- specpdl
;
4337 unwind_data
= Fcons (current_buffer
->enable_multibyte_characters
,
4338 Fcons (current_buffer
->undo_list
,
4339 Fcurrent_buffer ()));
4340 current_buffer
->enable_multibyte_characters
= Qnil
;
4341 current_buffer
->undo_list
= Qt
;
4342 record_unwind_protect (decide_coding_unwind
, unwind_data
);
4344 if (inserted
> 0 && ! NILP (Vset_auto_coding_function
))
4346 val
= call2 (Vset_auto_coding_function
,
4347 filename
, make_number (inserted
));
4352 /* If the coding system is not yet decided, check
4353 file-coding-system-alist. */
4354 Lisp_Object args
[6], coding_systems
;
4356 args
[0] = Qinsert_file_contents
, args
[1] = orig_filename
;
4357 args
[2] = visit
, args
[3] = beg
, args
[4] = end
, args
[5] = Qnil
;
4358 coding_systems
= Ffind_operation_coding_system (6, args
);
4359 if (CONSP (coding_systems
))
4360 val
= XCAR (coding_systems
);
4363 unbind_to (count
, Qnil
);
4364 inserted
= Z_BYTE
- BEG_BYTE
;
4367 /* The following kludgy code is to avoid some compiler bug.
4369 setup_coding_system (val, &coding);
4372 struct coding_system temp_coding
;
4373 setup_coding_system (val
, &temp_coding
);
4374 bcopy (&temp_coding
, &coding
, sizeof coding
);
4376 /* Ensure we set Vlast_coding_system_used. */
4377 set_coding_system
= 1;
4379 if (NILP (current_buffer
->enable_multibyte_characters
)
4381 /* We must suppress all character code conversion except for
4382 end-of-line conversion. */
4383 setup_raw_text_coding_system (&coding
);
4384 coding
.src_multibyte
= 0;
4385 coding
.dst_multibyte
4386 = !NILP (current_buffer
->enable_multibyte_characters
);
4390 /* Can't do this if part of the buffer might be preserved. */
4392 && (coding
.type
== coding_type_no_conversion
4393 || coding
.type
== coding_type_raw_text
))
4395 /* Visiting a file with these coding system makes the buffer
4397 current_buffer
->enable_multibyte_characters
= Qnil
;
4398 coding
.dst_multibyte
= 0;
4401 if (inserted
> 0 || coding
.type
== coding_type_ccl
)
4403 if (CODING_MAY_REQUIRE_DECODING (&coding
))
4405 code_convert_region (PT
, PT_BYTE
, PT
+ inserted
, PT_BYTE
+ inserted
,
4407 inserted
= coding
.produced_char
;
4410 adjust_after_insert (PT
, PT_BYTE
, PT
+ inserted
, PT_BYTE
+ inserted
,
4415 /* Use the conversion type to determine buffer-file-type
4416 (find-buffer-file-type is now used to help determine the
4418 if ((coding
.eol_type
== CODING_EOL_UNDECIDED
4419 || coding
.eol_type
== CODING_EOL_LF
)
4420 && ! CODING_REQUIRE_DECODING (&coding
))
4421 current_buffer
->buffer_file_type
= Qt
;
4423 current_buffer
->buffer_file_type
= Qnil
;
4430 if (!EQ (current_buffer
->undo_list
, Qt
))
4431 current_buffer
->undo_list
= Qnil
;
4433 stat (XSTRING (filename
)->data
, &st
);
4438 current_buffer
->modtime
= st
.st_mtime
;
4439 current_buffer
->filename
= orig_filename
;
4442 SAVE_MODIFF
= MODIFF
;
4443 current_buffer
->auto_save_modified
= MODIFF
;
4444 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4445 #ifdef CLASH_DETECTION
4448 if (!NILP (current_buffer
->file_truename
))
4449 unlock_file (current_buffer
->file_truename
);
4450 unlock_file (filename
);
4452 #endif /* CLASH_DETECTION */
4454 Fsignal (Qfile_error
,
4455 Fcons (build_string ("not a regular file"),
4456 Fcons (orig_filename
, Qnil
)));
4459 /* Decode file format */
4462 int empty_undo_list_p
= 0;
4464 /* If we're anyway going to discard undo information, don't
4465 record it in the first place. The buffer's undo list at this
4466 point is either nil or t when visiting a file. */
4469 empty_undo_list_p
= NILP (current_buffer
->undo_list
);
4470 current_buffer
->undo_list
= Qt
;
4473 insval
= call3 (Qformat_decode
,
4474 Qnil
, make_number (inserted
), visit
);
4475 CHECK_NUMBER (insval
);
4476 inserted
= XFASTINT (insval
);
4479 current_buffer
->undo_list
= empty_undo_list_p
? Qnil
: Qt
;
4482 if (set_coding_system
)
4483 Vlast_coding_system_used
= coding
.symbol
;
4485 /* Call after-change hooks for the inserted text, aside from the case
4486 of normal visiting (not with REPLACE), which is done in a new buffer
4487 "before" the buffer is changed. */
4488 if (inserted
> 0 && total
> 0
4489 && (NILP (visit
) || !NILP (replace
)))
4491 signal_after_change (PT
, 0, inserted
);
4492 update_compositions (PT
, PT
, CHECK_BORDER
);
4495 p
= Vafter_insert_file_functions
;
4498 insval
= call1 (Fcar (p
), make_number (inserted
));
4501 CHECK_NUMBER (insval
);
4502 inserted
= XFASTINT (insval
);
4509 && current_buffer
->modtime
== -1)
4511 /* If visiting nonexistent file, return nil. */
4512 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
4516 Fsignal (Qquit
, Qnil
);
4518 /* ??? Retval needs to be dealt with in all cases consistently. */
4520 val
= Fcons (orig_filename
,
4521 Fcons (make_number (inserted
),
4524 RETURN_UNGCPRO (unbind_to (count
, val
));
4527 static Lisp_Object build_annotations
P_ ((Lisp_Object
, Lisp_Object
));
4528 static Lisp_Object build_annotations_2
P_ ((Lisp_Object
, Lisp_Object
,
4529 Lisp_Object
, Lisp_Object
));
4531 /* If build_annotations switched buffers, switch back to BUF.
4532 Kill the temporary buffer that was selected in the meantime.
4534 Since this kill only the last temporary buffer, some buffers remain
4535 not killed if build_annotations switched buffers more than once.
4539 build_annotations_unwind (buf
)
4544 if (XBUFFER (buf
) == current_buffer
)
4546 tembuf
= Fcurrent_buffer ();
4548 Fkill_buffer (tembuf
);
4552 /* Decide the coding-system to encode the data with. */
4555 choose_write_coding_system (start
, end
, filename
,
4556 append
, visit
, lockname
, coding
)
4557 Lisp_Object start
, end
, filename
, append
, visit
, lockname
;
4558 struct coding_system
*coding
;
4564 else if (!NILP (Vcoding_system_for_write
))
4565 val
= Vcoding_system_for_write
;
4568 /* If the variable `buffer-file-coding-system' is set locally,
4569 it means that the file was read with some kind of code
4570 conversion or the variable is explicitly set by users. We
4571 had better write it out with the same coding system even if
4572 `enable-multibyte-characters' is nil.
4574 If it is not set locally, we anyway have to convert EOL
4575 format if the default value of `buffer-file-coding-system'
4576 tells that it is not Unix-like (LF only) format. */
4577 int using_default_coding
= 0;
4578 int force_raw_text
= 0;
4580 val
= current_buffer
->buffer_file_coding_system
;
4582 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4585 if (NILP (current_buffer
->enable_multibyte_characters
))
4591 /* Check file-coding-system-alist. */
4592 Lisp_Object args
[7], coding_systems
;
4594 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4595 args
[3] = filename
; args
[4] = append
; args
[5] = visit
;
4597 coding_systems
= Ffind_operation_coding_system (7, args
);
4598 if (CONSP (coding_systems
) && !NILP (XCDR (coding_systems
)))
4599 val
= XCDR (coding_systems
);
4603 && !NILP (current_buffer
->buffer_file_coding_system
))
4605 /* If we still have not decided a coding system, use the
4606 default value of buffer-file-coding-system. */
4607 val
= current_buffer
->buffer_file_coding_system
;
4608 using_default_coding
= 1;
4612 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4613 /* Confirm that VAL can surely encode the current region. */
4614 val
= call3 (Vselect_safe_coding_system_function
, start
, end
, val
);
4616 setup_coding_system (Fcheck_coding_system (val
), coding
);
4617 if (coding
->eol_type
== CODING_EOL_UNDECIDED
4618 && !using_default_coding
)
4620 if (! EQ (default_buffer_file_coding
.symbol
,
4621 buffer_defaults
.buffer_file_coding_system
))
4622 setup_coding_system (buffer_defaults
.buffer_file_coding_system
,
4623 &default_buffer_file_coding
);
4624 if (default_buffer_file_coding
.eol_type
!= CODING_EOL_UNDECIDED
)
4626 Lisp_Object subsidiaries
;
4628 coding
->eol_type
= default_buffer_file_coding
.eol_type
;
4629 subsidiaries
= Fget (coding
->symbol
, Qeol_type
);
4630 if (VECTORP (subsidiaries
)
4631 && XVECTOR (subsidiaries
)->size
== 3)
4633 = XVECTOR (subsidiaries
)->contents
[coding
->eol_type
];
4638 setup_raw_text_coding_system (coding
);
4639 goto done_setup_coding
;
4642 setup_coding_system (Fcheck_coding_system (val
), coding
);
4645 if (!STRINGP (start
) && !NILP (current_buffer
->selective_display
))
4646 coding
->mode
|= CODING_MODE_SELECTIVE_DISPLAY
;
4649 DEFUN ("write-region", Fwrite_region
, Swrite_region
, 3, 7,
4650 "r\nFWrite region to file: \ni\ni\ni\np",
4651 doc
: /* Write current region into specified file.
4652 When called from a program, takes three arguments:
4653 START, END and FILENAME. START and END are buffer positions.
4654 Optional fourth argument APPEND if non-nil means
4655 append to existing file contents (if any). If it is an integer,
4656 seek to that offset in the file before writing.
4657 Optional fifth argument VISIT if t means
4658 set the last-save-file-modtime of buffer to this file's modtime
4659 and mark buffer not modified.
4660 If VISIT is a string, it is a second file name;
4661 the output goes to FILENAME, but the buffer is marked as visiting VISIT.
4662 VISIT is also the file name to lock and unlock for clash detection.
4663 If VISIT is neither t nor nil nor a string,
4664 that means do not print the \"Wrote file\" message.
4665 The optional sixth arg LOCKNAME, if non-nil, specifies the name to
4666 use for locking and unlocking, overriding FILENAME and VISIT.
4667 The optional seventh arg MUSTBENEW, if non-nil, insists on a check
4668 for an existing file with the same name. If MUSTBENEW is `excl',
4669 that means to get an error if the file already exists; never overwrite.
4670 If MUSTBENEW is neither nil nor `excl', that means ask for
4671 confirmation before overwriting, but do go ahead and overwrite the file
4672 if the user confirms.
4673 Kludgy feature: if START is a string, then that string is written
4674 to the file, instead of any buffer contents, and END is ignored.
4676 This does code conversion according to the value of
4677 `coding-system-for-write', `buffer-file-coding-system', or
4678 `file-coding-system-alist', and sets the variable
4679 `last-coding-system-used' to the coding system actually used. */)
4680 (start
, end
, filename
, append
, visit
, lockname
, mustbenew
)
4681 Lisp_Object start
, end
, filename
, append
, visit
, lockname
, mustbenew
;
4689 int count
= specpdl_ptr
- specpdl
;
4692 unsigned char *fname
= 0; /* If non-0, original filename (must rename) */
4694 Lisp_Object handler
;
4695 Lisp_Object visit_file
;
4696 Lisp_Object annotations
;
4697 Lisp_Object encoded_filename
;
4698 int visiting
= (EQ (visit
, Qt
) || STRINGP (visit
));
4699 int quietly
= !NILP (visit
);
4700 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
4701 struct buffer
*given_buffer
;
4703 int buffer_file_type
= O_BINARY
;
4705 struct coding_system coding
;
4707 if (current_buffer
->base_buffer
&& visiting
)
4708 error ("Cannot do file visiting in an indirect buffer");
4710 if (!NILP (start
) && !STRINGP (start
))
4711 validate_region (&start
, &end
);
4713 GCPRO5 (start
, filename
, visit
, visit_file
, lockname
);
4715 filename
= Fexpand_file_name (filename
, Qnil
);
4717 if (!NILP (mustbenew
) && !EQ (mustbenew
, Qexcl
))
4718 barf_or_query_if_file_exists (filename
, "overwrite", 1, 0, 1);
4720 if (STRINGP (visit
))
4721 visit_file
= Fexpand_file_name (visit
, Qnil
);
4723 visit_file
= filename
;
4725 if (NILP (lockname
))
4726 lockname
= visit_file
;
4730 /* If the file name has special constructs in it,
4731 call the corresponding file handler. */
4732 handler
= Ffind_file_name_handler (filename
, Qwrite_region
);
4733 /* If FILENAME has no handler, see if VISIT has one. */
4734 if (NILP (handler
) && STRINGP (visit
))
4735 handler
= Ffind_file_name_handler (visit
, Qwrite_region
);
4737 if (!NILP (handler
))
4740 val
= call6 (handler
, Qwrite_region
, start
, end
,
4741 filename
, append
, visit
);
4745 SAVE_MODIFF
= MODIFF
;
4746 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4747 current_buffer
->filename
= visit_file
;
4753 /* Special kludge to simplify auto-saving. */
4756 XSETFASTINT (start
, BEG
);
4757 XSETFASTINT (end
, Z
);
4760 record_unwind_protect (build_annotations_unwind
, Fcurrent_buffer ());
4761 count1
= specpdl_ptr
- specpdl
;
4763 given_buffer
= current_buffer
;
4764 annotations
= build_annotations (start
, end
);
4765 if (current_buffer
!= given_buffer
)
4767 XSETFASTINT (start
, BEGV
);
4768 XSETFASTINT (end
, ZV
);
4773 GCPRO5 (start
, filename
, annotations
, visit_file
, lockname
);
4775 /* Decide the coding-system to encode the data with.
4776 We used to make this choice before calling build_annotations, but that
4777 leads to problems when a write-annotate-function takes care of
4778 unsavable chars (as was the case with X-Symbol). */
4779 choose_write_coding_system (start
, end
, filename
,
4780 append
, visit
, lockname
, &coding
);
4781 Vlast_coding_system_used
= coding
.symbol
;
4783 given_buffer
= current_buffer
;
4784 annotations
= build_annotations_2 (start
, end
,
4785 coding
.pre_write_conversion
, annotations
);
4786 if (current_buffer
!= given_buffer
)
4788 XSETFASTINT (start
, BEGV
);
4789 XSETFASTINT (end
, ZV
);
4792 #ifdef CLASH_DETECTION
4795 #if 0 /* This causes trouble for GNUS. */
4796 /* If we've locked this file for some other buffer,
4797 query before proceeding. */
4798 if (!visiting
&& EQ (Ffile_locked_p (lockname
), Qt
))
4799 call2 (intern ("ask-user-about-lock"), filename
, Vuser_login_name
);
4802 lock_file (lockname
);
4804 #endif /* CLASH_DETECTION */
4806 encoded_filename
= ENCODE_FILE (filename
);
4808 fn
= XSTRING (encoded_filename
)->data
;
4812 desc
= emacs_open (fn
, O_WRONLY
| buffer_file_type
, 0);
4813 #else /* not DOS_NT */
4814 desc
= emacs_open (fn
, O_WRONLY
, 0);
4815 #endif /* not DOS_NT */
4817 if (desc
< 0 && (NILP (append
) || errno
== ENOENT
))
4819 if (auto_saving
) /* Overwrite any previous version of autosave file */
4821 vms_truncate (fn
); /* if fn exists, truncate to zero length */
4822 desc
= emacs_open (fn
, O_RDWR
, 0);
4824 desc
= creat_copy_attrs (STRINGP (current_buffer
->filename
)
4825 ? XSTRING (current_buffer
->filename
)->data
: 0,
4828 else /* Write to temporary name and rename if no errors */
4830 Lisp_Object temp_name
;
4831 temp_name
= Ffile_name_directory (filename
);
4833 if (!NILP (temp_name
))
4835 temp_name
= Fmake_temp_name (concat2 (temp_name
,
4836 build_string ("$$SAVE$$")));
4837 fname
= XSTRING (filename
)->data
;
4838 fn
= XSTRING (temp_name
)->data
;
4839 desc
= creat_copy_attrs (fname
, fn
);
4842 /* If we can't open the temporary file, try creating a new
4843 version of the original file. VMS "creat" creates a
4844 new version rather than truncating an existing file. */
4847 desc
= creat (fn
, 0666);
4848 #if 0 /* This can clobber an existing file and fail to replace it,
4849 if the user runs out of space. */
4852 /* We can't make a new version;
4853 try to truncate and rewrite existing version if any. */
4855 desc
= emacs_open (fn
, O_RDWR
, 0);
4861 desc
= creat (fn
, 0666);
4865 desc
= emacs_open (fn
,
4866 O_WRONLY
| O_CREAT
| buffer_file_type
4867 | (EQ (mustbenew
, Qexcl
) ? O_EXCL
: O_TRUNC
),
4868 S_IREAD
| S_IWRITE
);
4869 #else /* not DOS_NT */
4870 desc
= emacs_open (fn
, O_WRONLY
| O_TRUNC
| O_CREAT
4871 | (EQ (mustbenew
, Qexcl
) ? O_EXCL
: 0),
4872 auto_saving
? auto_save_mode_bits
: 0666);
4873 #endif /* not DOS_NT */
4874 #endif /* not VMS */
4878 #ifdef CLASH_DETECTION
4880 if (!auto_saving
) unlock_file (lockname
);
4882 #endif /* CLASH_DETECTION */
4884 report_file_error ("Opening output file", Fcons (filename
, Qnil
));
4887 record_unwind_protect (close_file_unwind
, make_number (desc
));
4889 if (!NILP (append
) && !NILP (Ffile_regular_p (filename
)))
4893 if (NUMBERP (append
))
4894 ret
= lseek (desc
, XINT (append
), 1);
4896 ret
= lseek (desc
, 0, 2);
4899 #ifdef CLASH_DETECTION
4900 if (!auto_saving
) unlock_file (lockname
);
4901 #endif /* CLASH_DETECTION */
4903 report_file_error ("Lseek error", Fcons (filename
, Qnil
));
4911 * Kludge Warning: The VMS C RTL likes to insert carriage returns
4912 * if we do writes that don't end with a carriage return. Furthermore
4913 * it cannot handle writes of more then 16K. The modified
4914 * version of "sys_write" in SYSDEP.C (see comment there) copes with
4915 * this EXCEPT for the last record (iff it doesn't end with a carriage
4916 * return). This implies that if your buffer doesn't end with a carriage
4917 * return, you get one free... tough. However it also means that if
4918 * we make two calls to sys_write (a la the following code) you can
4919 * get one at the gap as well. The easiest way to fix this (honest)
4920 * is to move the gap to the next newline (or the end of the buffer).
4925 if (GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4926 move_gap (find_next_newline (GPT
, 1));
4928 /* Whether VMS or not, we must move the gap to the next of newline
4929 when we must put designation sequences at beginning of line. */
4930 if (INTEGERP (start
)
4931 && coding
.type
== coding_type_iso2022
4932 && coding
.flags
& CODING_FLAG_ISO_DESIGNATE_AT_BOL
4933 && GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4935 int opoint
= PT
, opoint_byte
= PT_BYTE
;
4936 scan_newline (PT
, PT_BYTE
, ZV
, ZV_BYTE
, 1, 0);
4937 move_gap_both (PT
, PT_BYTE
);
4938 SET_PT_BOTH (opoint
, opoint_byte
);
4945 if (STRINGP (start
))
4947 failure
= 0 > a_write (desc
, start
, 0, XSTRING (start
)->size
,
4948 &annotations
, &coding
);
4951 else if (XINT (start
) != XINT (end
))
4953 tem
= CHAR_TO_BYTE (XINT (start
));
4955 if (XINT (start
) < GPT
)
4957 failure
= 0 > a_write (desc
, Qnil
, XINT (start
),
4958 min (GPT
, XINT (end
)) - XINT (start
),
4959 &annotations
, &coding
);
4963 if (XINT (end
) > GPT
&& !failure
)
4965 tem
= max (XINT (start
), GPT
);
4966 failure
= 0 > a_write (desc
, Qnil
, tem
, XINT (end
) - tem
,
4967 &annotations
, &coding
);
4973 /* If file was empty, still need to write the annotations */
4974 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4975 failure
= 0 > a_write (desc
, Qnil
, XINT (end
), 0, &annotations
, &coding
);
4979 if (CODING_REQUIRE_FLUSHING (&coding
)
4980 && !(coding
.mode
& CODING_MODE_LAST_BLOCK
)
4983 /* We have to flush out a data. */
4984 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4985 failure
= 0 > e_write (desc
, Qnil
, 0, 0, &coding
);
4992 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
4993 Disk full in NFS may be reported here. */
4994 /* mib says that closing the file will try to write as fast as NFS can do
4995 it, and that means the fsync here is not crucial for autosave files. */
4996 if (!auto_saving
&& fsync (desc
) < 0)
4998 /* If fsync fails with EINTR, don't treat that as serious. */
5000 failure
= 1, save_errno
= errno
;
5004 /* Spurious "file has changed on disk" warnings have been
5005 observed on Suns as well.
5006 It seems that `close' can change the modtime, under nfs.
5008 (This has supposedly been fixed in Sunos 4,
5009 but who knows about all the other machines with NFS?) */
5012 /* On VMS and APOLLO, must do the stat after the close
5013 since closing changes the modtime. */
5016 /* Recall that #if defined does not work on VMS. */
5023 /* NFS can report a write failure now. */
5024 if (emacs_close (desc
) < 0)
5025 failure
= 1, save_errno
= errno
;
5028 /* If we wrote to a temporary name and had no errors, rename to real name. */
5032 failure
= (rename (fn
, fname
) != 0), save_errno
= errno
;
5040 /* Discard the unwind protect for close_file_unwind. */
5041 specpdl_ptr
= specpdl
+ count1
;
5042 /* Restore the original current buffer. */
5043 visit_file
= unbind_to (count
, visit_file
);
5045 #ifdef CLASH_DETECTION
5047 unlock_file (lockname
);
5048 #endif /* CLASH_DETECTION */
5050 /* Do this before reporting IO error
5051 to avoid a "file has changed on disk" warning on
5052 next attempt to save. */
5054 current_buffer
->modtime
= st
.st_mtime
;
5057 error ("IO error writing %s: %s", XSTRING (filename
)->data
,
5058 emacs_strerror (save_errno
));
5062 SAVE_MODIFF
= MODIFF
;
5063 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
5064 current_buffer
->filename
= visit_file
;
5065 update_mode_lines
++;
5071 message_with_string ("Wrote %s", visit_file
, 1);
5076 Lisp_Object
merge ();
5078 DEFUN ("car-less-than-car", Fcar_less_than_car
, Scar_less_than_car
, 2, 2, 0,
5079 doc
: /* Return t if (car A) is numerically less than (car B). */)
5083 return Flss (Fcar (a
), Fcar (b
));
5086 /* Build the complete list of annotations appropriate for writing out
5087 the text between START and END, by calling all the functions in
5088 write-region-annotate-functions and merging the lists they return.
5089 If one of these functions switches to a different buffer, we assume
5090 that buffer contains altered text. Therefore, the caller must
5091 make sure to restore the current buffer in all cases,
5092 as save-excursion would do. */
5095 build_annotations (start
, end
)
5096 Lisp_Object start
, end
;
5098 Lisp_Object annotations
;
5100 struct gcpro gcpro1
, gcpro2
;
5101 Lisp_Object original_buffer
;
5104 XSETBUFFER (original_buffer
, current_buffer
);
5107 p
= Vwrite_region_annotate_functions
;
5108 GCPRO2 (annotations
, p
);
5111 struct buffer
*given_buffer
= current_buffer
;
5112 Vwrite_region_annotations_so_far
= annotations
;
5113 res
= call2 (Fcar (p
), start
, end
);
5114 /* If the function makes a different buffer current,
5115 assume that means this buffer contains altered text to be output.
5116 Reset START and END from the buffer bounds
5117 and discard all previous annotations because they should have
5118 been dealt with by this function. */
5119 if (current_buffer
!= given_buffer
)
5121 XSETFASTINT (start
, BEGV
);
5122 XSETFASTINT (end
, ZV
);
5125 Flength (res
); /* Check basic validity of return value */
5126 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
5130 /* Now do the same for annotation functions implied by the file-format */
5131 if (auto_saving
&& (!EQ (Vauto_save_file_format
, Qt
)))
5132 p
= Vauto_save_file_format
;
5134 p
= current_buffer
->file_format
;
5135 for (i
= 0; !NILP (p
); p
= Fcdr (p
), ++i
)
5137 struct buffer
*given_buffer
= current_buffer
;
5139 Vwrite_region_annotations_so_far
= annotations
;
5141 /* Value is either a list of annotations or nil if the function
5142 has written annotations to a temporary buffer, which is now
5144 res
= call5 (Qformat_annotate_function
, Fcar (p
), start
, end
,
5145 original_buffer
, make_number (i
));
5146 if (current_buffer
!= given_buffer
)
5148 XSETFASTINT (start
, BEGV
);
5149 XSETFASTINT (end
, ZV
);
5154 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
5162 build_annotations_2 (start
, end
, pre_write_conversion
, annotations
)
5163 Lisp_Object start
, end
, pre_write_conversion
, annotations
;
5165 struct gcpro gcpro1
;
5168 GCPRO1 (annotations
);
5169 /* At last, do the same for the function PRE_WRITE_CONVERSION
5170 implied by the current coding-system. */
5171 if (!NILP (pre_write_conversion
))
5173 struct buffer
*given_buffer
= current_buffer
;
5174 Vwrite_region_annotations_so_far
= annotations
;
5175 res
= call2 (pre_write_conversion
, start
, end
);
5177 annotations
= (current_buffer
!= given_buffer
5179 : merge (annotations
, res
, Qcar_less_than_car
));
5186 /* Write to descriptor DESC the NCHARS chars starting at POS of STRING.
5187 If STRING is nil, POS is the character position in the current buffer.
5188 Intersperse with them the annotations from *ANNOT
5189 which fall within the range of POS to POS + NCHARS,
5190 each at its appropriate position.
5192 We modify *ANNOT by discarding elements as we use them up.
5194 The return value is negative in case of system call failure. */
5197 a_write (desc
, string
, pos
, nchars
, annot
, coding
)
5200 register int nchars
;
5203 struct coding_system
*coding
;
5207 int lastpos
= pos
+ nchars
;
5209 while (NILP (*annot
) || CONSP (*annot
))
5211 tem
= Fcar_safe (Fcar (*annot
));
5214 nextpos
= XFASTINT (tem
);
5216 /* If there are no more annotations in this range,
5217 output the rest of the range all at once. */
5218 if (! (nextpos
>= pos
&& nextpos
<= lastpos
))
5219 return e_write (desc
, string
, pos
, lastpos
, coding
);
5221 /* Output buffer text up to the next annotation's position. */
5224 if (0 > e_write (desc
, string
, pos
, nextpos
, coding
))
5228 /* Output the annotation. */
5229 tem
= Fcdr (Fcar (*annot
));
5232 if (0 > e_write (desc
, tem
, 0, XSTRING (tem
)->size
, coding
))
5235 *annot
= Fcdr (*annot
);
5240 #ifndef WRITE_BUF_SIZE
5241 #define WRITE_BUF_SIZE (16 * 1024)
5244 /* Write text in the range START and END into descriptor DESC,
5245 encoding them with coding system CODING. If STRING is nil, START
5246 and END are character positions of the current buffer, else they
5247 are indexes to the string STRING. */
5250 e_write (desc
, string
, start
, end
, coding
)
5254 struct coding_system
*coding
;
5256 register char *addr
;
5257 register int nbytes
;
5258 char buf
[WRITE_BUF_SIZE
];
5262 coding
->composing
= COMPOSITION_DISABLED
;
5263 if (coding
->composing
!= COMPOSITION_DISABLED
)
5264 coding_save_composition (coding
, start
, end
, string
);
5266 if (STRINGP (string
))
5268 addr
= XSTRING (string
)->data
;
5269 nbytes
= STRING_BYTES (XSTRING (string
));
5270 coding
->src_multibyte
= STRING_MULTIBYTE (string
);
5272 else if (start
< end
)
5274 /* It is assured that the gap is not in the range START and END-1. */
5275 addr
= CHAR_POS_ADDR (start
);
5276 nbytes
= CHAR_TO_BYTE (end
) - CHAR_TO_BYTE (start
);
5277 coding
->src_multibyte
5278 = !NILP (current_buffer
->enable_multibyte_characters
);
5284 coding
->src_multibyte
= 1;
5287 /* We used to have a code for handling selective display here. But,
5288 now it is handled within encode_coding. */
5293 result
= encode_coding (coding
, addr
, buf
, nbytes
, WRITE_BUF_SIZE
);
5294 if (coding
->produced
> 0)
5296 coding
->produced
-= emacs_write (desc
, buf
, coding
->produced
);
5297 if (coding
->produced
)
5303 nbytes
-= coding
->consumed
;
5304 addr
+= coding
->consumed
;
5305 if (result
== CODING_FINISH_INSUFFICIENT_SRC
5308 /* The source text ends by an incomplete multibyte form.
5309 There's no way other than write it out as is. */
5310 nbytes
-= emacs_write (desc
, addr
, nbytes
);
5319 start
+= coding
->consumed_char
;
5320 if (coding
->cmp_data
)
5321 coding_adjust_composition_offset (coding
, start
);
5324 if (coding
->cmp_data
)
5325 coding_free_composition_data (coding
);
5330 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime
,
5331 Sverify_visited_file_modtime
, 1, 1, 0,
5332 doc
: /* Return t if last mod time of BUF's visited file matches what BUF records.
5333 This means that the file has not been changed since it was visited or saved. */)
5339 Lisp_Object handler
;
5340 Lisp_Object filename
;
5345 if (!STRINGP (b
->filename
)) return Qt
;
5346 if (b
->modtime
== 0) return Qt
;
5348 /* If the file name has special constructs in it,
5349 call the corresponding file handler. */
5350 handler
= Ffind_file_name_handler (b
->filename
,
5351 Qverify_visited_file_modtime
);
5352 if (!NILP (handler
))
5353 return call2 (handler
, Qverify_visited_file_modtime
, buf
);
5355 filename
= ENCODE_FILE (b
->filename
);
5357 if (stat (XSTRING (filename
)->data
, &st
) < 0)
5359 /* If the file doesn't exist now and didn't exist before,
5360 we say that it isn't modified, provided the error is a tame one. */
5361 if (errno
== ENOENT
|| errno
== EACCES
|| errno
== ENOTDIR
)
5366 if (st
.st_mtime
== b
->modtime
5367 /* If both are positive, accept them if they are off by one second. */
5368 || (st
.st_mtime
> 0 && b
->modtime
> 0
5369 && (st
.st_mtime
== b
->modtime
+ 1
5370 || st
.st_mtime
== b
->modtime
- 1)))
5375 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime
,
5376 Sclear_visited_file_modtime
, 0, 0, 0,
5377 doc
: /* Clear out records of last mod time of visited file.
5378 Next attempt to save will certainly not complain of a discrepancy. */)
5381 current_buffer
->modtime
= 0;
5385 DEFUN ("visited-file-modtime", Fvisited_file_modtime
,
5386 Svisited_file_modtime
, 0, 0, 0,
5387 doc
: /* Return the current buffer's recorded visited file modification time.
5388 The value is a list of the form (HIGH . LOW), like the time values
5389 that `file-attributes' returns. */)
5392 return long_to_cons ((unsigned long) current_buffer
->modtime
);
5395 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime
,
5396 Sset_visited_file_modtime
, 0, 1, 0,
5397 doc
: /* Update buffer's recorded modification time from the visited file's time.
5398 Useful if the buffer was not read from the file normally
5399 or if the file itself has been changed for some known benign reason.
5400 An argument specifies the modification time value to use
5401 \(instead of that of the visited file), in the form of a list
5402 \(HIGH . LOW) or (HIGH LOW). */)
5404 Lisp_Object time_list
;
5406 if (!NILP (time_list
))
5407 current_buffer
->modtime
= cons_to_long (time_list
);
5410 register Lisp_Object filename
;
5412 Lisp_Object handler
;
5414 filename
= Fexpand_file_name (current_buffer
->filename
, Qnil
);
5416 /* If the file name has special constructs in it,
5417 call the corresponding file handler. */
5418 handler
= Ffind_file_name_handler (filename
, Qset_visited_file_modtime
);
5419 if (!NILP (handler
))
5420 /* The handler can find the file name the same way we did. */
5421 return call2 (handler
, Qset_visited_file_modtime
, Qnil
);
5423 filename
= ENCODE_FILE (filename
);
5425 if (stat (XSTRING (filename
)->data
, &st
) >= 0)
5426 current_buffer
->modtime
= st
.st_mtime
;
5433 auto_save_error (error
)
5436 Lisp_Object args
[3], msg
;
5438 struct gcpro gcpro1
;
5442 args
[0] = build_string ("Auto-saving %s: %s");
5443 args
[1] = current_buffer
->name
;
5444 args
[2] = Ferror_message_string (error
);
5445 msg
= Fformat (3, args
);
5447 nbytes
= STRING_BYTES (XSTRING (msg
));
5449 for (i
= 0; i
< 3; ++i
)
5452 message2 (XSTRING (msg
)->data
, nbytes
, STRING_MULTIBYTE (msg
));
5454 message2_nolog (XSTRING (msg
)->data
, nbytes
, STRING_MULTIBYTE (msg
));
5455 Fsleep_for (make_number (1), Qnil
);
5467 /* Get visited file's mode to become the auto save file's mode. */
5468 if (! NILP (current_buffer
->filename
)
5469 && stat (XSTRING (current_buffer
->filename
)->data
, &st
) >= 0)
5470 /* But make sure we can overwrite it later! */
5471 auto_save_mode_bits
= st
.st_mode
| 0600;
5473 auto_save_mode_bits
= 0666;
5476 Fwrite_region (Qnil
, Qnil
,
5477 current_buffer
->auto_save_file_name
,
5478 Qnil
, Qlambda
, Qnil
, Qnil
);
5482 do_auto_save_unwind (stream
) /* used as unwind-protect function */
5487 fclose ((FILE *) (XFASTINT (XCAR (stream
)) << 16
5488 | XFASTINT (XCDR (stream
))));
5494 do_auto_save_unwind_1 (value
) /* used as unwind-protect function */
5497 minibuffer_auto_raise
= XINT (value
);
5501 DEFUN ("do-auto-save", Fdo_auto_save
, Sdo_auto_save
, 0, 2, "",
5502 doc
: /* Auto-save all buffers that need it.
5503 This is all buffers that have auto-saving enabled
5504 and are changed since last auto-saved.
5505 Auto-saving writes the buffer into a file
5506 so that your editing is not lost if the system crashes.
5507 This file is not the file you visited; that changes only when you save.
5508 Normally we run the normal hook `auto-save-hook' before saving.
5510 A non-nil NO-MESSAGE argument means do not print any message if successful.
5511 A non-nil CURRENT-ONLY argument means save only current buffer. */)
5512 (no_message
, current_only
)
5513 Lisp_Object no_message
, current_only
;
5515 struct buffer
*old
= current_buffer
, *b
;
5516 Lisp_Object tail
, buf
;
5518 int do_handled_files
;
5521 Lisp_Object lispstream
;
5522 int count
= specpdl_ptr
- specpdl
;
5523 int orig_minibuffer_auto_raise
= minibuffer_auto_raise
;
5524 int message_p
= push_message ();
5526 /* Ordinarily don't quit within this function,
5527 but don't make it impossible to quit (in case we get hung in I/O). */
5531 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
5532 point to non-strings reached from Vbuffer_alist. */
5537 if (!NILP (Vrun_hooks
))
5538 call1 (Vrun_hooks
, intern ("auto-save-hook"));
5540 if (STRINGP (Vauto_save_list_file_name
))
5542 Lisp_Object listfile
;
5544 listfile
= Fexpand_file_name (Vauto_save_list_file_name
, Qnil
);
5546 /* Don't try to create the directory when shutting down Emacs,
5547 because creating the directory might signal an error, and
5548 that would leave Emacs in a strange state. */
5549 if (!NILP (Vrun_hooks
))
5552 dir
= Ffile_name_directory (listfile
);
5553 if (NILP (Ffile_directory_p (dir
)))
5554 call2 (Qmake_directory
, dir
, Qt
);
5557 stream
= fopen (XSTRING (listfile
)->data
, "w");
5560 /* Arrange to close that file whether or not we get an error.
5561 Also reset auto_saving to 0. */
5562 lispstream
= Fcons (Qnil
, Qnil
);
5563 XSETCARFASTINT (lispstream
, (EMACS_UINT
)stream
>> 16);
5564 XSETCDRFASTINT (lispstream
, (EMACS_UINT
)stream
& 0xffff);
5575 record_unwind_protect (do_auto_save_unwind
, lispstream
);
5576 record_unwind_protect (do_auto_save_unwind_1
,
5577 make_number (minibuffer_auto_raise
));
5578 minibuffer_auto_raise
= 0;
5581 /* First, save all files which don't have handlers. If Emacs is
5582 crashing, the handlers may tweak what is causing Emacs to crash
5583 in the first place, and it would be a shame if Emacs failed to
5584 autosave perfectly ordinary files because it couldn't handle some
5586 for (do_handled_files
= 0; do_handled_files
< 2; do_handled_files
++)
5587 for (tail
= Vbuffer_alist
; GC_CONSP (tail
); tail
= XCDR (tail
))
5589 buf
= XCDR (XCAR (tail
));
5592 /* Record all the buffers that have auto save mode
5593 in the special file that lists them. For each of these buffers,
5594 Record visited name (if any) and auto save name. */
5595 if (STRINGP (b
->auto_save_file_name
)
5596 && stream
!= NULL
&& do_handled_files
== 0)
5598 if (!NILP (b
->filename
))
5600 fwrite (XSTRING (b
->filename
)->data
, 1,
5601 STRING_BYTES (XSTRING (b
->filename
)), stream
);
5603 putc ('\n', stream
);
5604 fwrite (XSTRING (b
->auto_save_file_name
)->data
, 1,
5605 STRING_BYTES (XSTRING (b
->auto_save_file_name
)), stream
);
5606 putc ('\n', stream
);
5609 if (!NILP (current_only
)
5610 && b
!= current_buffer
)
5613 /* Don't auto-save indirect buffers.
5614 The base buffer takes care of it. */
5618 /* Check for auto save enabled
5619 and file changed since last auto save
5620 and file changed since last real save. */
5621 if (STRINGP (b
->auto_save_file_name
)
5622 && BUF_SAVE_MODIFF (b
) < BUF_MODIFF (b
)
5623 && b
->auto_save_modified
< BUF_MODIFF (b
)
5624 /* -1 means we've turned off autosaving for a while--see below. */
5625 && XINT (b
->save_length
) >= 0
5626 && (do_handled_files
5627 || NILP (Ffind_file_name_handler (b
->auto_save_file_name
,
5630 EMACS_TIME before_time
, after_time
;
5632 EMACS_GET_TIME (before_time
);
5634 /* If we had a failure, don't try again for 20 minutes. */
5635 if (b
->auto_save_failure_time
>= 0
5636 && EMACS_SECS (before_time
) - b
->auto_save_failure_time
< 1200)
5639 if ((XFASTINT (b
->save_length
) * 10
5640 > (BUF_Z (b
) - BUF_BEG (b
)) * 13)
5641 /* A short file is likely to change a large fraction;
5642 spare the user annoying messages. */
5643 && XFASTINT (b
->save_length
) > 5000
5644 /* These messages are frequent and annoying for `*mail*'. */
5645 && !EQ (b
->filename
, Qnil
)
5646 && NILP (no_message
))
5648 /* It has shrunk too much; turn off auto-saving here. */
5649 minibuffer_auto_raise
= orig_minibuffer_auto_raise
;
5650 message_with_string ("Buffer %s has shrunk a lot; auto save turned off there",
5652 minibuffer_auto_raise
= 0;
5653 /* Turn off auto-saving until there's a real save,
5654 and prevent any more warnings. */
5655 XSETINT (b
->save_length
, -1);
5656 Fsleep_for (make_number (1), Qnil
);
5659 set_buffer_internal (b
);
5660 if (!auto_saved
&& NILP (no_message
))
5661 message1 ("Auto-saving...");
5662 internal_condition_case (auto_save_1
, Qt
, auto_save_error
);
5664 b
->auto_save_modified
= BUF_MODIFF (b
);
5665 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
5666 set_buffer_internal (old
);
5668 EMACS_GET_TIME (after_time
);
5670 /* If auto-save took more than 60 seconds,
5671 assume it was an NFS failure that got a timeout. */
5672 if (EMACS_SECS (after_time
) - EMACS_SECS (before_time
) > 60)
5673 b
->auto_save_failure_time
= EMACS_SECS (after_time
);
5677 /* Prevent another auto save till enough input events come in. */
5678 record_auto_save ();
5680 if (auto_saved
&& NILP (no_message
))
5684 sit_for (1, 0, 0, 0, 0);
5688 message1 ("Auto-saving...done");
5693 unbind_to (count
, Qnil
);
5697 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved
,
5698 Sset_buffer_auto_saved
, 0, 0, 0,
5699 doc
: /* Mark current buffer as auto-saved with its current text.
5700 No auto-save file will be written until the buffer changes again. */)
5703 current_buffer
->auto_save_modified
= MODIFF
;
5704 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
5705 current_buffer
->auto_save_failure_time
= -1;
5709 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure
,
5710 Sclear_buffer_auto_save_failure
, 0, 0, 0,
5711 doc
: /* Clear any record of a recent auto-save failure in the current buffer. */)
5714 current_buffer
->auto_save_failure_time
= -1;
5718 DEFUN ("recent-auto-save-p", Frecent_auto_save_p
, Srecent_auto_save_p
,
5720 doc
: /* Return t if buffer has been auto-saved since last read in or saved. */)
5723 return (SAVE_MODIFF
< current_buffer
->auto_save_modified
) ? Qt
: Qnil
;
5726 /* Reading and completing file names */
5727 extern Lisp_Object
Ffile_name_completion (), Ffile_name_all_completions ();
5729 /* In the string VAL, change each $ to $$ and return the result. */
5732 double_dollars (val
)
5735 register unsigned char *old
, *new;
5739 osize
= STRING_BYTES (XSTRING (val
));
5741 /* Count the number of $ characters. */
5742 for (n
= osize
, count
= 0, old
= XSTRING (val
)->data
; n
> 0; n
--)
5743 if (*old
++ == '$') count
++;
5746 old
= XSTRING (val
)->data
;
5747 val
= make_uninit_multibyte_string (XSTRING (val
)->size
+ count
,
5749 new = XSTRING (val
)->data
;
5750 for (n
= osize
; n
> 0; n
--)
5763 DEFUN ("read-file-name-internal", Fread_file_name_internal
, Sread_file_name_internal
,
5765 doc
: /* Internal subroutine for read-file-name. Do not call this. */)
5766 (string
, dir
, action
)
5767 Lisp_Object string
, dir
, action
;
5768 /* action is nil for complete, t for return list of completions,
5769 lambda for verify final value */
5771 Lisp_Object name
, specdir
, realdir
, val
, orig_string
;
5773 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
5775 CHECK_STRING (string
);
5782 /* No need to protect ACTION--we only compare it with t and nil. */
5783 GCPRO5 (string
, realdir
, name
, specdir
, orig_string
);
5785 if (XSTRING (string
)->size
== 0)
5787 if (EQ (action
, Qlambda
))
5795 orig_string
= string
;
5796 string
= Fsubstitute_in_file_name (string
);
5797 changed
= NILP (Fstring_equal (string
, orig_string
));
5798 name
= Ffile_name_nondirectory (string
);
5799 val
= Ffile_name_directory (string
);
5801 realdir
= Fexpand_file_name (val
, realdir
);
5806 specdir
= Ffile_name_directory (string
);
5807 val
= Ffile_name_completion (name
, realdir
);
5812 return double_dollars (string
);
5816 if (!NILP (specdir
))
5817 val
= concat2 (specdir
, val
);
5819 return double_dollars (val
);
5822 #endif /* not VMS */
5826 if (EQ (action
, Qt
))
5827 return Ffile_name_all_completions (name
, realdir
);
5828 /* Only other case actually used is ACTION = lambda */
5830 /* Supposedly this helps commands such as `cd' that read directory names,
5831 but can someone explain how it helps them? -- RMS */
5832 if (XSTRING (name
)->size
== 0)
5835 return Ffile_exists_p (string
);
5838 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
5839 doc
: /* Read file name, prompting with PROMPT and completing in directory DIR.
5840 Value is not expanded---you must call `expand-file-name' yourself.
5841 Default name to DEFAULT-FILENAME if user enters a null string.
5842 (If DEFAULT-FILENAME is omitted, the visited file name is used,
5843 except that if INITIAL is specified, that combined with DIR is used.)
5844 Fourth arg MUSTMATCH non-nil means require existing file's name.
5845 Non-nil and non-t means also require confirmation after completion.
5846 Fifth arg INITIAL specifies text to start with.
5847 DIR defaults to current buffer's directory default.
5849 If this command was invoked with the mouse, use a file dialog box if
5850 `use-dialog-box' is non-nil, and the window system or X toolkit in use
5851 provides a file dialog box. */)
5852 (prompt
, dir
, default_filename
, mustmatch
, initial
)
5853 Lisp_Object prompt
, dir
, default_filename
, mustmatch
, initial
;
5855 Lisp_Object val
, insdef
, tem
;
5856 struct gcpro gcpro1
, gcpro2
;
5857 register char *homedir
;
5858 int replace_in_history
= 0;
5859 int add_to_history
= 0;
5863 dir
= current_buffer
->directory
;
5864 if (NILP (default_filename
))
5866 if (! NILP (initial
))
5867 default_filename
= Fexpand_file_name (initial
, dir
);
5869 default_filename
= current_buffer
->filename
;
5872 /* If dir starts with user's homedir, change that to ~. */
5873 homedir
= (char *) egetenv ("HOME");
5875 /* homedir can be NULL in temacs, since Vprocess_environment is not
5876 yet set up. We shouldn't crash in that case. */
5879 homedir
= strcpy (alloca (strlen (homedir
) + 1), homedir
);
5880 CORRECT_DIR_SEPS (homedir
);
5885 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
5886 && IS_DIRECTORY_SEP (XSTRING (dir
)->data
[strlen (homedir
)]))
5888 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
5889 STRING_BYTES (XSTRING (dir
)) - strlen (homedir
) + 1);
5890 XSTRING (dir
)->data
[0] = '~';
5892 /* Likewise for default_filename. */
5894 && STRINGP (default_filename
)
5895 && !strncmp (homedir
, XSTRING (default_filename
)->data
, strlen (homedir
))
5896 && IS_DIRECTORY_SEP (XSTRING (default_filename
)->data
[strlen (homedir
)]))
5899 = make_string (XSTRING (default_filename
)->data
+ strlen (homedir
) - 1,
5900 STRING_BYTES (XSTRING (default_filename
)) - strlen (homedir
) + 1);
5901 XSTRING (default_filename
)->data
[0] = '~';
5903 if (!NILP (default_filename
))
5905 CHECK_STRING (default_filename
);
5906 default_filename
= double_dollars (default_filename
);
5909 if (insert_default_directory
&& STRINGP (dir
))
5912 if (!NILP (initial
))
5914 Lisp_Object args
[2], pos
;
5918 insdef
= Fconcat (2, args
);
5919 pos
= make_number (XSTRING (double_dollars (dir
))->size
);
5920 insdef
= Fcons (double_dollars (insdef
), pos
);
5923 insdef
= double_dollars (insdef
);
5925 else if (STRINGP (initial
))
5926 insdef
= Fcons (double_dollars (initial
), make_number (0));
5930 count
= specpdl_ptr
- specpdl
;
5932 specbind (intern ("completion-ignore-case"), Qt
);
5935 specbind (intern ("minibuffer-completing-file-name"), Qt
);
5937 GCPRO2 (insdef
, default_filename
);
5939 #if defined (USE_MOTIF) || defined (HAVE_NTGUI)
5940 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
5944 /* If DIR contains a file name, split it. */
5946 file
= Ffile_name_nondirectory (dir
);
5947 if (XSTRING (file
)->size
&& NILP (default_filename
))
5949 default_filename
= file
;
5950 dir
= Ffile_name_directory (dir
);
5952 if (!NILP(default_filename
))
5953 default_filename
= Fexpand_file_name (default_filename
, dir
);
5954 val
= Fx_file_dialog (prompt
, dir
, default_filename
, mustmatch
);
5959 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
5960 dir
, mustmatch
, insdef
,
5961 Qfile_name_history
, default_filename
, Qnil
);
5963 tem
= Fsymbol_value (Qfile_name_history
);
5964 if (CONSP (tem
) && EQ (XCAR (tem
), val
))
5965 replace_in_history
= 1;
5967 /* If Fcompleting_read returned the inserted default string itself
5968 (rather than a new string with the same contents),
5969 it has to mean that the user typed RET with the minibuffer empty.
5970 In that case, we really want to return ""
5971 so that commands such as set-visited-file-name can distinguish. */
5972 if (EQ (val
, default_filename
))
5974 /* In this case, Fcompleting_read has not added an element
5975 to the history. Maybe we should. */
5976 if (! replace_in_history
)
5979 val
= build_string ("");
5982 unbind_to (count
, Qnil
);
5985 error ("No file name specified");
5987 tem
= Fstring_equal (val
, CONSP (insdef
) ? XCAR (insdef
) : insdef
);
5989 if (!NILP (tem
) && !NILP (default_filename
))
5990 val
= default_filename
;
5991 else if (XSTRING (val
)->size
== 0 && NILP (insdef
))
5993 if (!NILP (default_filename
))
5994 val
= default_filename
;
5996 error ("No default file name");
5998 val
= Fsubstitute_in_file_name (val
);
6000 if (replace_in_history
)
6001 /* Replace what Fcompleting_read added to the history
6002 with what we will actually return. */
6003 XSETCAR (Fsymbol_value (Qfile_name_history
), double_dollars (val
));
6004 else if (add_to_history
)
6006 /* Add the value to the history--but not if it matches
6007 the last value already there. */
6008 Lisp_Object val1
= double_dollars (val
);
6009 tem
= Fsymbol_value (Qfile_name_history
);
6010 if (! CONSP (tem
) || NILP (Fequal (XCAR (tem
), val1
)))
6011 Fset (Qfile_name_history
,
6022 /* Must be set before any path manipulation is performed. */
6023 XSETFASTINT (Vdirectory_sep_char
, '/');
6030 Qexpand_file_name
= intern ("expand-file-name");
6031 Qsubstitute_in_file_name
= intern ("substitute-in-file-name");
6032 Qdirectory_file_name
= intern ("directory-file-name");
6033 Qfile_name_directory
= intern ("file-name-directory");
6034 Qfile_name_nondirectory
= intern ("file-name-nondirectory");
6035 Qunhandled_file_name_directory
= intern ("unhandled-file-name-directory");
6036 Qfile_name_as_directory
= intern ("file-name-as-directory");
6037 Qcopy_file
= intern ("copy-file");
6038 Qmake_directory_internal
= intern ("make-directory-internal");
6039 Qmake_directory
= intern ("make-directory");
6040 Qdelete_directory
= intern ("delete-directory");
6041 Qdelete_file
= intern ("delete-file");
6042 Qrename_file
= intern ("rename-file");
6043 Qadd_name_to_file
= intern ("add-name-to-file");
6044 Qmake_symbolic_link
= intern ("make-symbolic-link");
6045 Qfile_exists_p
= intern ("file-exists-p");
6046 Qfile_executable_p
= intern ("file-executable-p");
6047 Qfile_readable_p
= intern ("file-readable-p");
6048 Qfile_writable_p
= intern ("file-writable-p");
6049 Qfile_symlink_p
= intern ("file-symlink-p");
6050 Qaccess_file
= intern ("access-file");
6051 Qfile_directory_p
= intern ("file-directory-p");
6052 Qfile_regular_p
= intern ("file-regular-p");
6053 Qfile_accessible_directory_p
= intern ("file-accessible-directory-p");
6054 Qfile_modes
= intern ("file-modes");
6055 Qset_file_modes
= intern ("set-file-modes");
6056 Qfile_newer_than_file_p
= intern ("file-newer-than-file-p");
6057 Qinsert_file_contents
= intern ("insert-file-contents");
6058 Qwrite_region
= intern ("write-region");
6059 Qverify_visited_file_modtime
= intern ("verify-visited-file-modtime");
6060 Qset_visited_file_modtime
= intern ("set-visited-file-modtime");
6062 staticpro (&Qexpand_file_name
);
6063 staticpro (&Qsubstitute_in_file_name
);
6064 staticpro (&Qdirectory_file_name
);
6065 staticpro (&Qfile_name_directory
);
6066 staticpro (&Qfile_name_nondirectory
);
6067 staticpro (&Qunhandled_file_name_directory
);
6068 staticpro (&Qfile_name_as_directory
);
6069 staticpro (&Qcopy_file
);
6070 staticpro (&Qmake_directory_internal
);
6071 staticpro (&Qmake_directory
);
6072 staticpro (&Qdelete_directory
);
6073 staticpro (&Qdelete_file
);
6074 staticpro (&Qrename_file
);
6075 staticpro (&Qadd_name_to_file
);
6076 staticpro (&Qmake_symbolic_link
);
6077 staticpro (&Qfile_exists_p
);
6078 staticpro (&Qfile_executable_p
);
6079 staticpro (&Qfile_readable_p
);
6080 staticpro (&Qfile_writable_p
);
6081 staticpro (&Qaccess_file
);
6082 staticpro (&Qfile_symlink_p
);
6083 staticpro (&Qfile_directory_p
);
6084 staticpro (&Qfile_regular_p
);
6085 staticpro (&Qfile_accessible_directory_p
);
6086 staticpro (&Qfile_modes
);
6087 staticpro (&Qset_file_modes
);
6088 staticpro (&Qfile_newer_than_file_p
);
6089 staticpro (&Qinsert_file_contents
);
6090 staticpro (&Qwrite_region
);
6091 staticpro (&Qverify_visited_file_modtime
);
6092 staticpro (&Qset_visited_file_modtime
);
6094 Qfile_name_history
= intern ("file-name-history");
6095 Fset (Qfile_name_history
, Qnil
);
6096 staticpro (&Qfile_name_history
);
6098 Qfile_error
= intern ("file-error");
6099 staticpro (&Qfile_error
);
6100 Qfile_already_exists
= intern ("file-already-exists");
6101 staticpro (&Qfile_already_exists
);
6102 Qfile_date_error
= intern ("file-date-error");
6103 staticpro (&Qfile_date_error
);
6104 Qexcl
= intern ("excl");
6108 Qfind_buffer_file_type
= intern ("find-buffer-file-type");
6109 staticpro (&Qfind_buffer_file_type
);
6112 DEFVAR_LISP ("file-name-coding-system", &Vfile_name_coding_system
,
6113 doc
: /* *Coding system for encoding file names.
6114 If it is nil, default-file-name-coding-system (which see) is used. */);
6115 Vfile_name_coding_system
= Qnil
;
6117 DEFVAR_LISP ("default-file-name-coding-system",
6118 &Vdefault_file_name_coding_system
,
6119 doc
: /* Default coding system for encoding file names.
6120 This variable is used only when file-name-coding-system is nil.
6122 This variable is set/changed by the command set-language-environment.
6123 User should not set this variable manually,
6124 instead use file-name-coding-system to get a constant encoding
6125 of file names regardless of the current language environment. */);
6126 Vdefault_file_name_coding_system
= Qnil
;
6128 DEFVAR_LISP ("auto-save-file-format", &Vauto_save_file_format
,
6129 doc
: /* *Format in which to write auto-save files.
6130 Should be a list of symbols naming formats that are defined in `format-alist'.
6131 If it is t, which is the default, auto-save files are written in the
6132 same format as a regular save would use. */);
6133 Vauto_save_file_format
= Qt
;
6135 Qformat_decode
= intern ("format-decode");
6136 staticpro (&Qformat_decode
);
6137 Qformat_annotate_function
= intern ("format-annotate-function");
6138 staticpro (&Qformat_annotate_function
);
6140 Qcar_less_than_car
= intern ("car-less-than-car");
6141 staticpro (&Qcar_less_than_car
);
6143 Fput (Qfile_error
, Qerror_conditions
,
6144 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
)));
6145 Fput (Qfile_error
, Qerror_message
,
6146 build_string ("File error"));
6148 Fput (Qfile_already_exists
, Qerror_conditions
,
6149 Fcons (Qfile_already_exists
,
6150 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
6151 Fput (Qfile_already_exists
, Qerror_message
,
6152 build_string ("File already exists"));
6154 Fput (Qfile_date_error
, Qerror_conditions
,
6155 Fcons (Qfile_date_error
,
6156 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
6157 Fput (Qfile_date_error
, Qerror_message
,
6158 build_string ("Cannot set file date"));
6160 DEFVAR_BOOL ("insert-default-directory", &insert_default_directory
,
6161 doc
: /* *Non-nil means when reading a filename start with default dir in minibuffer. */);
6162 insert_default_directory
= 1;
6164 DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm
,
6165 doc
: /* *Non-nil means write new files with record format `stmlf'.
6166 nil means use format `var'. This variable is meaningful only on VMS. */);
6167 vms_stmlf_recfm
= 0;
6169 DEFVAR_LISP ("directory-sep-char", &Vdirectory_sep_char
,
6170 doc
: /* Directory separator character for built-in functions that return file names.
6171 The value should be either ?/ or ?\\ (any other value is treated as ?\\).
6172 This variable affects the built-in functions only on Windows,
6173 on other platforms, it is initialized so that Lisp code can find out
6174 what the normal separator is.
6176 WARNING: This variable is deprecated and will be removed in the near
6177 future. DO NOT USE IT. */);
6179 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist
,
6180 doc
: /* *Alist of elements (REGEXP . HANDLER) for file names handled specially.
6181 If a file name matches REGEXP, then all I/O on that file is done by calling
6184 The first argument given to HANDLER is the name of the I/O primitive
6185 to be handled; the remaining arguments are the arguments that were
6186 passed to that primitive. For example, if you do
6187 (file-exists-p FILENAME)
6188 and FILENAME is handled by HANDLER, then HANDLER is called like this:
6189 (funcall HANDLER 'file-exists-p FILENAME)
6190 The function `find-file-name-handler' checks this list for a handler
6191 for its argument. */);
6192 Vfile_name_handler_alist
= Qnil
;
6194 DEFVAR_LISP ("set-auto-coding-function",
6195 &Vset_auto_coding_function
,
6196 doc
: /* If non-nil, a function to call to decide a coding system of file.
6197 Two arguments are passed to this function: the file name
6198 and the length of a file contents following the point.
6199 This function should return a coding system to decode the file contents.
6200 It should check the file name against `auto-coding-alist'.
6201 If no coding system is decided, it should check a coding system
6202 specified in the heading lines with the format:
6203 -*- ... coding: CODING-SYSTEM; ... -*-
6204 or local variable spec of the tailing lines with `coding:' tag. */);
6205 Vset_auto_coding_function
= Qnil
;
6207 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions
,
6208 doc
: /* A list of functions to be called at the end of `insert-file-contents'.
6209 Each is passed one argument, the number of bytes inserted. It should return
6210 the new byte count, and leave point the same. If `insert-file-contents' is
6211 intercepted by a handler from `file-name-handler-alist', that handler is
6212 responsible for calling the after-insert-file-functions if appropriate. */);
6213 Vafter_insert_file_functions
= Qnil
;
6215 DEFVAR_LISP ("write-region-annotate-functions", &Vwrite_region_annotate_functions
,
6216 doc
: /* A list of functions to be called at the start of `write-region'.
6217 Each is passed two arguments, START and END as for `write-region'.
6218 These are usually two numbers but not always; see the documentation
6219 for `write-region'. The function should return a list of pairs
6220 of the form (POSITION . STRING), consisting of strings to be effectively
6221 inserted at the specified positions of the file being written (1 means to
6222 insert before the first byte written). The POSITIONs must be sorted into
6223 increasing order. If there are several functions in the list, the several
6224 lists are merged destructively. */);
6225 Vwrite_region_annotate_functions
= Qnil
;
6227 DEFVAR_LISP ("write-region-annotations-so-far",
6228 &Vwrite_region_annotations_so_far
,
6229 doc
: /* When an annotation function is called, this holds the previous annotations.
6230 These are the annotations made by other annotation functions
6231 that were already called. See also `write-region-annotate-functions'. */);
6232 Vwrite_region_annotations_so_far
= Qnil
;
6234 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers
,
6235 doc
: /* A list of file name handlers that temporarily should not be used.
6236 This applies only to the operation `inhibit-file-name-operation'. */);
6237 Vinhibit_file_name_handlers
= Qnil
;
6239 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation
,
6240 doc
: /* The operation for which `inhibit-file-name-handlers' is applicable. */);
6241 Vinhibit_file_name_operation
= Qnil
;
6243 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name
,
6244 doc
: /* File name in which we write a list of all auto save file names.
6245 This variable is initialized automatically from `auto-save-list-file-prefix'
6246 shortly after Emacs reads your `.emacs' file, if you have not yet given it
6247 a non-nil value. */);
6248 Vauto_save_list_file_name
= Qnil
;
6250 defsubr (&Sfind_file_name_handler
);
6251 defsubr (&Sfile_name_directory
);
6252 defsubr (&Sfile_name_nondirectory
);
6253 defsubr (&Sunhandled_file_name_directory
);
6254 defsubr (&Sfile_name_as_directory
);
6255 defsubr (&Sdirectory_file_name
);
6256 defsubr (&Smake_temp_name
);
6257 defsubr (&Sexpand_file_name
);
6258 defsubr (&Ssubstitute_in_file_name
);
6259 defsubr (&Scopy_file
);
6260 defsubr (&Smake_directory_internal
);
6261 defsubr (&Sdelete_directory
);
6262 defsubr (&Sdelete_file
);
6263 defsubr (&Srename_file
);
6264 defsubr (&Sadd_name_to_file
);
6266 defsubr (&Smake_symbolic_link
);
6267 #endif /* S_IFLNK */
6269 defsubr (&Sdefine_logical_name
);
6272 defsubr (&Ssysnetunam
);
6273 #endif /* HPUX_NET */
6274 defsubr (&Sfile_name_absolute_p
);
6275 defsubr (&Sfile_exists_p
);
6276 defsubr (&Sfile_executable_p
);
6277 defsubr (&Sfile_readable_p
);
6278 defsubr (&Sfile_writable_p
);
6279 defsubr (&Saccess_file
);
6280 defsubr (&Sfile_symlink_p
);
6281 defsubr (&Sfile_directory_p
);
6282 defsubr (&Sfile_accessible_directory_p
);
6283 defsubr (&Sfile_regular_p
);
6284 defsubr (&Sfile_modes
);
6285 defsubr (&Sset_file_modes
);
6286 defsubr (&Sset_default_file_modes
);
6287 defsubr (&Sdefault_file_modes
);
6288 defsubr (&Sfile_newer_than_file_p
);
6289 defsubr (&Sinsert_file_contents
);
6290 defsubr (&Swrite_region
);
6291 defsubr (&Scar_less_than_car
);
6292 defsubr (&Sverify_visited_file_modtime
);
6293 defsubr (&Sclear_visited_file_modtime
);
6294 defsubr (&Svisited_file_modtime
);
6295 defsubr (&Sset_visited_file_modtime
);
6296 defsubr (&Sdo_auto_save
);
6297 defsubr (&Sset_buffer_auto_saved
);
6298 defsubr (&Sclear_buffer_auto_save_failure
);
6299 defsubr (&Srecent_auto_save_p
);
6301 defsubr (&Sread_file_name_internal
);
6302 defsubr (&Sread_file_name
);
6305 defsubr (&Sunix_sync
);