1 /* File IO for GNU Emacs.
2 Copyright (C) 1985,86,87,88,93,94,95,96,97,1998 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
23 #if defined (USG5) || defined (BSD_SYSTEM) || defined (LINUX)
28 #include <sys/types.h>
35 #if !defined (S_ISLNK) && defined (S_IFLNK)
36 # define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK)
39 #if !defined (S_ISFIFO) && defined (S_IFIFO)
40 # define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO)
43 #if !defined (S_ISREG) && defined (S_IFREG)
44 # define S_ISREG(m) (((m) & S_IFMT) == S_IFREG)
68 extern char *strerror ();
85 #include "intervals.h"
96 #endif /* not WINDOWSNT */
100 #include <sys/param.h>
108 #define CORRECT_DIR_SEPS(s) \
109 do { if ('/' == DIRECTORY_SEP) dostounix_filename (s); \
110 else unixtodos_filename (s); \
112 /* On Windows, drive letters must be alphabetic - on DOS, the Netware
113 redirector allows the six letters between 'Z' and 'a' as well. */
115 #define IS_DRIVE(x) ((x) >= 'A' && (x) <= 'z')
118 #define IS_DRIVE(x) isalpha (x)
120 /* Need to lower-case the drive letter, or else expanded
121 filenames will sometimes compare inequal, because
122 `expand-file-name' doesn't always down-case the drive letter. */
123 #define DRIVE_LETTER(x) (tolower (x))
152 #define min(a, b) ((a) < (b) ? (a) : (b))
153 #define max(a, b) ((a) > (b) ? (a) : (b))
155 /* Nonzero during writing of auto-save files */
158 /* Set by auto_save_1 to mode of original file so Fwrite_region will create
159 a new file with the same mode as the original */
160 int auto_save_mode_bits
;
162 /* Coding system for file names, or nil if none. */
163 Lisp_Object Vfile_name_coding_system
;
165 /* Coding system for file names used only when
166 Vfile_name_coding_system is nil. */
167 Lisp_Object Vdefault_file_name_coding_system
;
169 /* Alist of elements (REGEXP . HANDLER) for file names
170 whose I/O is done with a special handler. */
171 Lisp_Object Vfile_name_handler_alist
;
173 /* Format for auto-save files */
174 Lisp_Object Vauto_save_file_format
;
176 /* Lisp functions for translating file formats */
177 Lisp_Object Qformat_decode
, Qformat_annotate_function
;
179 /* Function to be called to decide a coding system of a reading file. */
180 Lisp_Object Vset_auto_coding_function
;
182 /* Functions to be called to process text properties in inserted file. */
183 Lisp_Object Vafter_insert_file_functions
;
185 /* Functions to be called to create text property annotations for file. */
186 Lisp_Object Vwrite_region_annotate_functions
;
188 /* During build_annotations, each time an annotation function is called,
189 this holds the annotations made by the previous functions. */
190 Lisp_Object Vwrite_region_annotations_so_far
;
192 /* File name in which we write a list of all our auto save files. */
193 Lisp_Object Vauto_save_list_file_name
;
195 /* Nonzero means, when reading a filename in the minibuffer,
196 start out by inserting the default directory into the minibuffer. */
197 int insert_default_directory
;
199 /* On VMS, nonzero means write new files with record format stmlf.
200 Zero means use var format. */
203 /* On NT, specifies the directory separator character, used (eg.) when
204 expanding file names. This can be bound to / or \. */
205 Lisp_Object Vdirectory_sep_char
;
207 extern Lisp_Object Vuser_login_name
;
209 extern int minibuf_level
;
211 extern int minibuffer_auto_raise
;
213 /* These variables describe handlers that have "already" had a chance
214 to handle the current operation.
216 Vinhibit_file_name_handlers is a list of file name handlers.
217 Vinhibit_file_name_operation is the operation being handled.
218 If we try to handle that operation, we ignore those handlers. */
220 static Lisp_Object Vinhibit_file_name_handlers
;
221 static Lisp_Object Vinhibit_file_name_operation
;
223 Lisp_Object Qfile_error
, Qfile_already_exists
, Qfile_date_error
;
225 Lisp_Object Qfile_name_history
;
227 Lisp_Object Qcar_less_than_car
;
229 static int a_write
P_ ((int, char *, int, int,
230 Lisp_Object
*, struct coding_system
*));
231 static int e_write
P_ ((int, char *, int, struct coding_system
*));
234 report_file_error (string
, data
)
238 Lisp_Object errstring
;
240 errstring
= build_string (strerror (errno
));
242 /* System error messages are capitalized. Downcase the initial
243 unless it is followed by a slash. */
244 if (XSTRING (errstring
)->data
[1] != '/')
245 XSTRING (errstring
)->data
[0] = DOWNCASE (XSTRING (errstring
)->data
[0]);
248 Fsignal (Qfile_error
,
249 Fcons (build_string (string
), Fcons (errstring
, data
)));
253 close_file_unwind (fd
)
256 close (XFASTINT (fd
));
260 /* Restore point, having saved it as a marker. */
263 restore_point_unwind (location
)
264 Lisp_Object location
;
266 Fgoto_char (location
);
267 Fset_marker (location
, Qnil
, Qnil
);
271 Lisp_Object Qexpand_file_name
;
272 Lisp_Object Qsubstitute_in_file_name
;
273 Lisp_Object Qdirectory_file_name
;
274 Lisp_Object Qfile_name_directory
;
275 Lisp_Object Qfile_name_nondirectory
;
276 Lisp_Object Qunhandled_file_name_directory
;
277 Lisp_Object Qfile_name_as_directory
;
278 Lisp_Object Qcopy_file
;
279 Lisp_Object Qmake_directory_internal
;
280 Lisp_Object Qdelete_directory
;
281 Lisp_Object Qdelete_file
;
282 Lisp_Object Qrename_file
;
283 Lisp_Object Qadd_name_to_file
;
284 Lisp_Object Qmake_symbolic_link
;
285 Lisp_Object Qfile_exists_p
;
286 Lisp_Object Qfile_executable_p
;
287 Lisp_Object Qfile_readable_p
;
288 Lisp_Object Qfile_writable_p
;
289 Lisp_Object Qfile_symlink_p
;
290 Lisp_Object Qaccess_file
;
291 Lisp_Object Qfile_directory_p
;
292 Lisp_Object Qfile_regular_p
;
293 Lisp_Object Qfile_accessible_directory_p
;
294 Lisp_Object Qfile_modes
;
295 Lisp_Object Qset_file_modes
;
296 Lisp_Object Qfile_newer_than_file_p
;
297 Lisp_Object Qinsert_file_contents
;
298 Lisp_Object Qwrite_region
;
299 Lisp_Object Qverify_visited_file_modtime
;
300 Lisp_Object Qset_visited_file_modtime
;
302 DEFUN ("find-file-name-handler", Ffind_file_name_handler
, Sfind_file_name_handler
, 2, 2, 0,
303 "Return FILENAME's handler function for OPERATION, if it has one.\n\
304 Otherwise, return nil.\n\
305 A file name is handled if one of the regular expressions in\n\
306 `file-name-handler-alist' matches it.\n\n\
307 If OPERATION equals `inhibit-file-name-operation', then we ignore\n\
308 any handlers that are members of `inhibit-file-name-handlers',\n\
309 but we still do run any other handlers. This lets handlers\n\
310 use the standard functions without calling themselves recursively.")
311 (filename
, operation
)
312 Lisp_Object filename
, operation
;
314 /* This function must not munge the match data. */
315 Lisp_Object chain
, inhibited_handlers
;
317 CHECK_STRING (filename
, 0);
319 if (EQ (operation
, Vinhibit_file_name_operation
))
320 inhibited_handlers
= Vinhibit_file_name_handlers
;
322 inhibited_handlers
= Qnil
;
324 for (chain
= Vfile_name_handler_alist
; CONSP (chain
);
325 chain
= XCONS (chain
)->cdr
)
328 elt
= XCONS (chain
)->car
;
332 string
= XCONS (elt
)->car
;
333 if (STRINGP (string
) && fast_string_match (string
, filename
) >= 0)
335 Lisp_Object handler
, tem
;
337 handler
= XCONS (elt
)->cdr
;
338 tem
= Fmemq (handler
, inhibited_handlers
);
349 DEFUN ("file-name-directory", Ffile_name_directory
, Sfile_name_directory
,
351 "Return the directory component in file name FILENAME.\n\
352 Return nil if FILENAME does not include a directory.\n\
353 Otherwise return a directory spec.\n\
354 Given a Unix syntax file name, returns a string ending in slash;\n\
355 on VMS, perhaps instead a string ending in `:', `]' or `>'.")
357 Lisp_Object filename
;
359 register unsigned char *beg
;
360 register unsigned char *p
;
363 CHECK_STRING (filename
, 0);
365 /* If the file name has special constructs in it,
366 call the corresponding file handler. */
367 handler
= Ffind_file_name_handler (filename
, Qfile_name_directory
);
369 return call2 (handler
, Qfile_name_directory
, filename
);
371 #ifdef FILE_SYSTEM_CASE
372 filename
= FILE_SYSTEM_CASE (filename
);
374 beg
= XSTRING (filename
)->data
;
376 beg
= strcpy (alloca (strlen (beg
) + 1), beg
);
378 p
= beg
+ STRING_BYTES (XSTRING (filename
));
380 while (p
!= beg
&& !IS_DIRECTORY_SEP (p
[-1])
382 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
385 /* only recognise drive specifier at beginning */
386 && !(p
[-1] == ':' && p
== beg
+ 2)
393 /* Expansion of "c:" to drive and default directory. */
394 if (p
== beg
+ 2 && beg
[1] == ':')
396 /* MAXPATHLEN+1 is guaranteed to be enough space for getdefdir. */
397 unsigned char *res
= alloca (MAXPATHLEN
+ 1);
398 if (getdefdir (toupper (*beg
) - 'A' + 1, res
))
400 if (!IS_DIRECTORY_SEP (res
[strlen (res
) - 1]))
403 p
= beg
+ strlen (beg
);
406 CORRECT_DIR_SEPS (beg
);
409 if (STRING_MULTIBYTE (filename
))
410 return make_string (beg
, p
- beg
);
411 return make_unibyte_string (beg
, p
- beg
);
414 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory
,
415 Sfile_name_nondirectory
, 1, 1, 0,
416 "Return file name FILENAME sans its directory.\n\
417 For example, in a Unix-syntax file name,\n\
418 this is everything after the last slash,\n\
419 or the entire name if it contains no slash.")
421 Lisp_Object filename
;
423 register unsigned char *beg
, *p
, *end
;
426 CHECK_STRING (filename
, 0);
428 /* If the file name has special constructs in it,
429 call the corresponding file handler. */
430 handler
= Ffind_file_name_handler (filename
, Qfile_name_nondirectory
);
432 return call2 (handler
, Qfile_name_nondirectory
, filename
);
434 beg
= XSTRING (filename
)->data
;
435 end
= p
= beg
+ STRING_BYTES (XSTRING (filename
));
437 while (p
!= beg
&& !IS_DIRECTORY_SEP (p
[-1])
439 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
442 /* only recognise drive specifier at beginning */
443 && !(p
[-1] == ':' && p
== beg
+ 2)
448 if (STRING_MULTIBYTE (filename
))
449 return make_string (p
, end
- p
);
450 return make_unibyte_string (p
, end
- p
);
453 DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory
,
454 Sunhandled_file_name_directory
, 1, 1, 0,
455 "Return a directly usable directory name somehow associated with FILENAME.\n\
456 A `directly usable' directory name is one that may be used without the\n\
457 intervention of any file handler.\n\
458 If FILENAME is a directly usable file itself, return\n\
459 \(file-name-directory FILENAME).\n\
460 The `call-process' and `start-process' functions use this function to\n\
461 get a current directory to run processes in.")
463 Lisp_Object filename
;
467 /* If the file name has special constructs in it,
468 call the corresponding file handler. */
469 handler
= Ffind_file_name_handler (filename
, Qunhandled_file_name_directory
);
471 return call2 (handler
, Qunhandled_file_name_directory
, filename
);
473 return Ffile_name_directory (filename
);
478 file_name_as_directory (out
, in
)
481 int size
= strlen (in
) - 1;
494 /* Is it already a directory string? */
495 if (in
[size
] == ':' || in
[size
] == ']' || in
[size
] == '>')
497 /* Is it a VMS directory file name? If so, hack VMS syntax. */
498 else if (! index (in
, '/')
499 && ((size
> 3 && ! strcmp (&in
[size
- 3], ".DIR"))
500 || (size
> 3 && ! strcmp (&in
[size
- 3], ".dir"))
501 || (size
> 5 && (! strncmp (&in
[size
- 5], ".DIR", 4)
502 || ! strncmp (&in
[size
- 5], ".dir", 4))
503 && (in
[size
- 1] == '.' || in
[size
- 1] == ';')
504 && in
[size
] == '1')))
506 register char *p
, *dot
;
510 dir:x.dir --> dir:[x]
511 dir:[x]y.dir --> dir:[x.y] */
513 while (p
!= in
&& *p
!= ':' && *p
!= '>' && *p
!= ']') p
--;
516 strncpy (out
, in
, p
- in
);
535 dot
= index (p
, '.');
538 /* blindly remove any extension */
539 size
= strlen (out
) + (dot
- p
);
540 strncat (out
, p
, dot
- p
);
551 /* For Unix syntax, Append a slash if necessary */
552 if (!IS_DIRECTORY_SEP (out
[size
]))
554 out
[size
+ 1] = DIRECTORY_SEP
;
555 out
[size
+ 2] = '\0';
558 CORRECT_DIR_SEPS (out
);
564 DEFUN ("file-name-as-directory", Ffile_name_as_directory
,
565 Sfile_name_as_directory
, 1, 1, 0,
566 "Return a string representing file FILENAME interpreted as a directory.\n\
567 This operation exists because a directory is also a file, but its name as\n\
568 a directory is different from its name as a file.\n\
569 The result can be used as the value of `default-directory'\n\
570 or passed as second argument to `expand-file-name'.\n\
571 For a Unix-syntax file name, just appends a slash.\n\
572 On VMS, converts \"[X]FOO.DIR\" to \"[X.FOO]\", etc.")
579 CHECK_STRING (file
, 0);
583 /* If the file name has special constructs in it,
584 call the corresponding file handler. */
585 handler
= Ffind_file_name_handler (file
, Qfile_name_as_directory
);
587 return call2 (handler
, Qfile_name_as_directory
, file
);
589 buf
= (char *) alloca (STRING_BYTES (XSTRING (file
)) + 10);
590 return build_string (file_name_as_directory (buf
, XSTRING (file
)->data
));
594 * Convert from directory name to filename.
596 * xyzzy:[mukesh.emacs] => xyzzy:[mukesh]emacs.dir.1
597 * xyzzy:[mukesh] => xyzzy:[000000]mukesh.dir.1
598 * On UNIX, it's simple: just make sure there isn't a terminating /
600 * Value is nonzero if the string output is different from the input.
604 directory_file_name (src
, dst
)
612 struct FAB fab
= cc$rms_fab
;
613 struct NAM nam
= cc$rms_nam
;
614 char esa
[NAM$C_MAXRSS
];
619 if (! index (src
, '/')
620 && (src
[slen
- 1] == ']'
621 || src
[slen
- 1] == ':'
622 || src
[slen
- 1] == '>'))
624 /* VMS style - convert [x.y.z] to [x.y]z, [x] to [000000]x */
626 fab
.fab$b_fns
= slen
;
627 fab
.fab$l_nam
= &nam
;
628 fab
.fab$l_fop
= FAB$M_NAM
;
631 nam
.nam$b_ess
= sizeof esa
;
632 nam
.nam$b_nop
|= NAM$M_SYNCHK
;
634 /* We call SYS$PARSE to handle such things as [--] for us. */
635 if (SYS$
PARSE (&fab
, 0, 0) == RMS$_NORMAL
)
637 slen
= nam
.nam$b_esl
;
638 if (esa
[slen
- 1] == ';' && esa
[slen
- 2] == '.')
643 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
645 /* what about when we have logical_name:???? */
646 if (src
[slen
- 1] == ':')
647 { /* Xlate logical name and see what we get */
648 ptr
= strcpy (dst
, src
); /* upper case for getenv */
651 if ('a' <= *ptr
&& *ptr
<= 'z')
655 dst
[slen
- 1] = 0; /* remove colon */
656 if (!(src
= egetenv (dst
)))
658 /* should we jump to the beginning of this procedure?
659 Good points: allows us to use logical names that xlate
661 Bad points: can be a problem if we just translated to a device
663 For now, I'll punt and always expect VMS names, and hope for
666 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
667 { /* no recursion here! */
673 { /* not a directory spec */
678 bracket
= src
[slen
- 1];
680 /* If bracket is ']' or '>', bracket - 2 is the corresponding
682 ptr
= index (src
, bracket
- 2);
684 { /* no opening bracket */
688 if (!(rptr
= rindex (src
, '.')))
691 strncpy (dst
, src
, slen
);
695 dst
[slen
++] = bracket
;
700 /* If we have the top-level of a rooted directory (i.e. xx:[000000]),
701 then translate the device and recurse. */
702 if (dst
[slen
- 1] == ':'
703 && dst
[slen
- 2] != ':' /* skip decnet nodes */
704 && strcmp (src
+ slen
, "[000000]") == 0)
706 dst
[slen
- 1] = '\0';
707 if ((ptr
= egetenv (dst
))
708 && (rlen
= strlen (ptr
) - 1) > 0
709 && (ptr
[rlen
] == ']' || ptr
[rlen
] == '>')
710 && ptr
[rlen
- 1] == '.')
712 char * buf
= (char *) alloca (strlen (ptr
) + 1);
716 return directory_file_name (buf
, dst
);
721 strcat (dst
, "[000000]");
725 rlen
= strlen (rptr
) - 1;
726 strncat (dst
, rptr
, rlen
);
727 dst
[slen
+ rlen
] = '\0';
728 strcat (dst
, ".DIR.1");
732 /* Process as Unix format: just remove any final slash.
733 But leave "/" unchanged; do not change it to "". */
736 /* Handle // as root for apollo's. */
737 if ((slen
> 2 && dst
[slen
- 1] == '/')
738 || (slen
> 1 && dst
[0] != '/' && dst
[slen
- 1] == '/'))
742 && IS_DIRECTORY_SEP (dst
[slen
- 1])
744 && !IS_ANY_SEP (dst
[slen
- 2])
750 CORRECT_DIR_SEPS (dst
);
755 DEFUN ("directory-file-name", Fdirectory_file_name
, Sdirectory_file_name
,
757 "Returns the file name of the directory named DIRECTORY.\n\
758 This is the name of the file that holds the data for the directory DIRECTORY.\n\
759 This operation exists because a directory is also a file, but its name as\n\
760 a directory is different from its name as a file.\n\
761 In Unix-syntax, this function just removes the final slash.\n\
762 On VMS, given a VMS-syntax directory name such as \"[X.Y]\",\n\
763 it returns a file name such as \"[X]Y.DIR.1\".")
765 Lisp_Object directory
;
770 CHECK_STRING (directory
, 0);
772 if (NILP (directory
))
775 /* If the file name has special constructs in it,
776 call the corresponding file handler. */
777 handler
= Ffind_file_name_handler (directory
, Qdirectory_file_name
);
779 return call2 (handler
, Qdirectory_file_name
, directory
);
782 /* 20 extra chars is insufficient for VMS, since we might perform a
783 logical name translation. an equivalence string can be up to 255
784 chars long, so grab that much extra space... - sss */
785 buf
= (char *) alloca (STRING_BYTES (XSTRING (directory
)) + 20 + 255);
787 buf
= (char *) alloca (STRING_BYTES (XSTRING (directory
)) + 20);
789 directory_file_name (XSTRING (directory
)->data
, buf
);
790 return build_string (buf
);
793 static char make_temp_name_tbl
[64] =
795 'A','B','C','D','E','F','G','H',
796 'I','J','K','L','M','N','O','P',
797 'Q','R','S','T','U','V','W','X',
798 'Y','Z','a','b','c','d','e','f',
799 'g','h','i','j','k','l','m','n',
800 'o','p','q','r','s','t','u','v',
801 'w','x','y','z','0','1','2','3',
802 '4','5','6','7','8','9','-','_'
804 static unsigned make_temp_name_count
, make_temp_name_count_initialized_p
;
806 DEFUN ("make-temp-name", Fmake_temp_name
, Smake_temp_name
, 1, 1, 0,
807 "Generate temporary file name (string) starting with PREFIX (a string).\n\
808 The Emacs process number forms part of the result,\n\
809 so there is no danger of generating a name being used by another process.\n\
811 In addition, this function makes an attempt to choose a name\n\
812 which has no existing file. To make this work,\n\
813 PREFIX should be an absolute file name.")
820 unsigned char *p
, *data
;
824 CHECK_STRING (prefix
, 0);
826 /* VAL is created by adding 6 characters to PREFIX. The first
827 three are the PID of this process, in base 64, and the second
828 three are incremented if the file already exists. This ensures
829 262144 unique file names per PID per PREFIX. */
831 pid
= (int) getpid ();
833 #ifdef HAVE_LONG_FILE_NAMES
834 sprintf (pidbuf
, "%d", pid
);
835 pidlen
= strlen (pidbuf
);
837 pidbuf
[0] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
838 pidbuf
[1] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
839 pidbuf
[2] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
843 len
= XSTRING (prefix
)->size
;
844 val
= make_uninit_string (len
+ 3 + pidlen
);
845 data
= XSTRING (val
)->data
;
846 bcopy(XSTRING (prefix
)->data
, data
, len
);
849 bcopy (pidbuf
, p
, pidlen
);
852 /* Here we try to minimize useless stat'ing when this function is
853 invoked many times successively with the same PREFIX. We achieve
854 this by initializing count to a random value, and incrementing it
856 if (!make_temp_name_count_initialized_p
)
858 make_temp_name_count
= (unsigned) time (NULL
);
859 make_temp_name_count_initialized_p
= 1;
865 unsigned num
= make_temp_name_count
++;
867 p
[0] = make_temp_name_tbl
[num
& 63], num
>>= 6;
868 p
[1] = make_temp_name_tbl
[num
& 63], num
>>= 6;
869 p
[2] = make_temp_name_tbl
[num
& 63], num
>>= 6;
871 if (stat (data
, &ignored
) < 0)
873 /* We want to return only if errno is ENOENT. */
877 /* The error here is dubious, but there is little else we
878 can do. The alternatives are to return nil, which is
879 as bad as (and in many cases worse than) throwing the
880 error, or to ignore the error, which will likely result
881 in looping through 262144 stat's, which is not only
882 SLOW, but also useless since it will fallback to the
883 errow below, anyway. */
884 report_file_error ("Cannot create temporary name for prefix `%s'",
885 Fcons (prefix
, Qnil
));
890 error ("Cannot create temporary name for prefix `%s'",
891 XSTRING (prefix
)->data
);
896 DEFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
897 "Convert filename NAME to absolute, and canonicalize it.\n\
898 Second arg DEFAULT-DIRECTORY is directory to start with if NAME is relative\n\
899 (does not start with slash); if DEFAULT-DIRECTORY is nil or missing,\n\
900 the current buffer's value of default-directory is used.\n\
901 File name components that are `.' are removed, and \n\
902 so are file name components followed by `..', along with the `..' itself;\n\
903 note that these simplifications are done without checking the resulting\n\
904 file names in the file system.\n\
905 An initial `~/' expands to your home directory.\n\
906 An initial `~USER/' expands to USER's home directory.\n\
907 See also the function `substitute-in-file-name'.")
908 (name
, default_directory
)
909 Lisp_Object name
, default_directory
;
913 register unsigned char *newdir
, *p
, *o
;
915 unsigned char *target
;
918 unsigned char * colon
= 0;
919 unsigned char * close
= 0;
920 unsigned char * slash
= 0;
921 unsigned char * brack
= 0;
922 int lbrack
= 0, rbrack
= 0;
927 int collapse_newdir
= 1;
932 CHECK_STRING (name
, 0);
934 /* If the file name has special constructs in it,
935 call the corresponding file handler. */
936 handler
= Ffind_file_name_handler (name
, Qexpand_file_name
);
938 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
940 /* Use the buffer's default-directory if DEFAULT_DIRECTORY is omitted. */
941 if (NILP (default_directory
))
942 default_directory
= current_buffer
->directory
;
943 if (! STRINGP (default_directory
))
944 default_directory
= build_string ("/");
946 if (!NILP (default_directory
))
948 handler
= Ffind_file_name_handler (default_directory
, Qexpand_file_name
);
950 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
953 o
= XSTRING (default_directory
)->data
;
955 /* Make sure DEFAULT_DIRECTORY is properly expanded.
956 It would be better to do this down below where we actually use
957 default_directory. Unfortunately, calling Fexpand_file_name recursively
958 could invoke GC, and the strings might be relocated. This would
959 be annoying because we have pointers into strings lying around
960 that would need adjusting, and people would add new pointers to
961 the code and forget to adjust them, resulting in intermittent bugs.
962 Putting this call here avoids all that crud.
964 The EQ test avoids infinite recursion. */
965 if (! NILP (default_directory
) && !EQ (default_directory
, name
)
966 /* Save time in some common cases - as long as default_directory
967 is not relative, it can be canonicalized with name below (if it
968 is needed at all) without requiring it to be expanded now. */
970 /* Detect MSDOS file names with drive specifiers. */
971 && ! (IS_DRIVE (o
[0]) && (IS_DEVICE_SEP (o
[1]) && IS_DIRECTORY_SEP (o
[2])))
973 /* Detect Windows file names in UNC format. */
974 && ! (IS_DIRECTORY_SEP (o
[0]) && IS_DIRECTORY_SEP (o
[1]))
976 #else /* not DOS_NT */
977 /* Detect Unix absolute file names (/... alone is not absolute on
979 && ! (IS_DIRECTORY_SEP (o
[0]))
980 #endif /* not DOS_NT */
986 default_directory
= Fexpand_file_name (default_directory
, Qnil
);
991 /* Filenames on VMS are always upper case. */
992 name
= Fupcase (name
);
994 #ifdef FILE_SYSTEM_CASE
995 name
= FILE_SYSTEM_CASE (name
);
998 nm
= XSTRING (name
)->data
;
1001 /* We will force directory separators to be either all \ or /, so make
1002 a local copy to modify, even if there ends up being no change. */
1003 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
1005 /* Find and remove drive specifier if present; this makes nm absolute
1006 even if the rest of the name appears to be relative. */
1008 unsigned char *colon
= rindex (nm
, ':');
1011 /* Only recognize colon as part of drive specifier if there is a
1012 single alphabetic character preceeding the colon (and if the
1013 character before the drive letter, if present, is a directory
1014 separator); this is to support the remote system syntax used by
1015 ange-ftp, and the "po:username" syntax for POP mailboxes. */
1019 else if (IS_DRIVE (colon
[-1])
1020 && (colon
== nm
+ 1 || IS_DIRECTORY_SEP (colon
[-2])))
1027 while (--colon
>= nm
)
1028 if (colon
[0] == ':')
1034 /* If we see "c://somedir", we want to strip the first slash after the
1035 colon when stripping the drive letter. Otherwise, this expands to
1037 if (drive
&& IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1039 #endif /* WINDOWSNT */
1043 /* Discard any previous drive specifier if nm is now in UNC format. */
1044 if (IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1050 /* If nm is absolute, look for /./ or /../ sequences; if none are
1051 found, we can probably return right away. We will avoid allocating
1052 a new string if name is already fully expanded. */
1054 IS_DIRECTORY_SEP (nm
[0])
1059 && (drive
|| IS_DIRECTORY_SEP (nm
[1]))
1066 /* If it turns out that the filename we want to return is just a
1067 suffix of FILENAME, we don't need to go through and edit
1068 things; we just need to construct a new string using data
1069 starting at the middle of FILENAME. If we set lose to a
1070 non-zero value, that means we've discovered that we can't do
1077 /* Since we know the name is absolute, we can assume that each
1078 element starts with a "/". */
1080 /* "." and ".." are hairy. */
1081 if (IS_DIRECTORY_SEP (p
[0])
1083 && (IS_DIRECTORY_SEP (p
[2])
1085 || (p
[2] == '.' && (IS_DIRECTORY_SEP (p
[3])
1092 /* if dev:[dir]/, move nm to / */
1093 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1094 nm
= (brack
? brack
+ 1 : colon
+ 1);
1095 lbrack
= rbrack
= 0;
1103 /* VMS pre V4.4,convert '-'s in filenames. */
1104 if (lbrack
== rbrack
)
1106 if (dots
< 2) /* this is to allow negative version numbers */
1111 if (lbrack
> rbrack
&&
1112 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1113 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1119 /* count open brackets, reset close bracket pointer */
1120 if (p
[0] == '[' || p
[0] == '<')
1121 lbrack
++, brack
= 0;
1122 /* count close brackets, set close bracket pointer */
1123 if (p
[0] == ']' || p
[0] == '>')
1124 rbrack
++, brack
= p
;
1125 /* detect ][ or >< */
1126 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1128 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1129 nm
= p
+ 1, lose
= 1;
1130 if (p
[0] == ':' && (colon
|| slash
))
1131 /* if dev1:[dir]dev2:, move nm to dev2: */
1137 /* if /name/dev:, move nm to dev: */
1140 /* if node::dev:, move colon following dev */
1141 else if (colon
&& colon
[-1] == ':')
1143 /* if dev1:dev2:, move nm to dev2: */
1144 else if (colon
&& colon
[-1] != ':')
1149 if (p
[0] == ':' && !colon
)
1155 if (lbrack
== rbrack
)
1158 else if (p
[0] == '.')
1166 if (index (nm
, '/'))
1167 return build_string (sys_translate_unix (nm
));
1170 /* Make sure directories are all separated with / or \ as
1171 desired, but avoid allocation of a new string when not
1173 CORRECT_DIR_SEPS (nm
);
1175 if (IS_DIRECTORY_SEP (nm
[1]))
1177 if (strcmp (nm
, XSTRING (name
)->data
) != 0)
1178 name
= build_string (nm
);
1182 /* drive must be set, so this is okay */
1183 if (strcmp (nm
- 2, XSTRING (name
)->data
) != 0)
1185 name
= make_string (nm
- 2, p
- nm
+ 2);
1186 XSTRING (name
)->data
[0] = DRIVE_LETTER (drive
);
1187 XSTRING (name
)->data
[1] = ':';
1190 #else /* not DOS_NT */
1191 if (nm
== XSTRING (name
)->data
)
1193 return build_string (nm
);
1194 #endif /* not DOS_NT */
1198 /* At this point, nm might or might not be an absolute file name. We
1199 need to expand ~ or ~user if present, otherwise prefix nm with
1200 default_directory if nm is not absolute, and finally collapse /./
1201 and /foo/../ sequences.
1203 We set newdir to be the appropriate prefix if one is needed:
1204 - the relevant user directory if nm starts with ~ or ~user
1205 - the specified drive's working dir (DOS/NT only) if nm does not
1207 - the value of default_directory.
1209 Note that these prefixes are not guaranteed to be absolute (except
1210 for the working dir of a drive). Therefore, to ensure we always
1211 return an absolute name, if the final prefix is not absolute we
1212 append it to the current working directory. */
1216 if (nm
[0] == '~') /* prefix ~ */
1218 if (IS_DIRECTORY_SEP (nm
[1])
1222 || nm
[1] == 0) /* ~ by itself */
1224 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1225 newdir
= (unsigned char *) "";
1228 collapse_newdir
= 0;
1231 nm
++; /* Don't leave the slash in nm. */
1234 else /* ~user/filename */
1236 for (p
= nm
; *p
&& (!IS_DIRECTORY_SEP (*p
)
1241 o
= (unsigned char *) alloca (p
- nm
+ 1);
1242 bcopy ((char *) nm
, o
, p
- nm
);
1245 pw
= (struct passwd
*) getpwnam (o
+ 1);
1248 newdir
= (unsigned char *) pw
-> pw_dir
;
1250 nm
= p
+ 1; /* skip the terminator */
1254 collapse_newdir
= 0;
1259 /* If we don't find a user of that name, leave the name
1260 unchanged; don't move nm forward to p. */
1265 /* On DOS and Windows, nm is absolute if a drive name was specified;
1266 use the drive's current directory as the prefix if needed. */
1267 if (!newdir
&& drive
)
1269 /* Get default directory if needed to make nm absolute. */
1270 if (!IS_DIRECTORY_SEP (nm
[0]))
1272 newdir
= alloca (MAXPATHLEN
+ 1);
1273 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1278 /* Either nm starts with /, or drive isn't mounted. */
1279 newdir
= alloca (4);
1280 newdir
[0] = DRIVE_LETTER (drive
);
1288 /* Finally, if no prefix has been specified and nm is not absolute,
1289 then it must be expanded relative to default_directory. */
1293 /* /... alone is not absolute on DOS and Windows. */
1294 && !IS_DIRECTORY_SEP (nm
[0])
1297 && !(IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1304 newdir
= XSTRING (default_directory
)->data
;
1310 /* First ensure newdir is an absolute name. */
1312 /* Detect MSDOS file names with drive specifiers. */
1313 ! (IS_DRIVE (newdir
[0])
1314 && IS_DEVICE_SEP (newdir
[1]) && IS_DIRECTORY_SEP (newdir
[2]))
1316 /* Detect Windows file names in UNC format. */
1317 && ! (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1321 /* Effectively, let newdir be (expand-file-name newdir cwd).
1322 Because of the admonition against calling expand-file-name
1323 when we have pointers into lisp strings, we accomplish this
1324 indirectly by prepending newdir to nm if necessary, and using
1325 cwd (or the wd of newdir's drive) as the new newdir. */
1327 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1332 if (!IS_DIRECTORY_SEP (nm
[0]))
1334 char * tmp
= alloca (strlen (newdir
) + strlen (nm
) + 2);
1335 file_name_as_directory (tmp
, newdir
);
1339 newdir
= alloca (MAXPATHLEN
+ 1);
1342 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1349 /* Strip off drive name from prefix, if present. */
1350 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1356 /* Keep only a prefix from newdir if nm starts with slash
1357 (//server/share for UNC, nothing otherwise). */
1358 if (IS_DIRECTORY_SEP (nm
[0]) && collapse_newdir
)
1361 if (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1363 newdir
= strcpy (alloca (strlen (newdir
) + 1), newdir
);
1365 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1367 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1379 /* Get rid of any slash at the end of newdir, unless newdir is
1380 just // (an incomplete UNC name). */
1381 length
= strlen (newdir
);
1382 if (length
> 0 && IS_DIRECTORY_SEP (newdir
[length
- 1])
1384 && !(length
== 2 && IS_DIRECTORY_SEP (newdir
[0]))
1388 unsigned char *temp
= (unsigned char *) alloca (length
);
1389 bcopy (newdir
, temp
, length
- 1);
1390 temp
[length
- 1] = 0;
1398 /* Now concatenate the directory and name to new space in the stack frame */
1399 tlen
+= strlen (nm
) + 1;
1401 /* Add reserved space for drive name. (The Microsoft x86 compiler
1402 produces incorrect code if the following two lines are combined.) */
1403 target
= (unsigned char *) alloca (tlen
+ 2);
1405 #else /* not DOS_NT */
1406 target
= (unsigned char *) alloca (tlen
);
1407 #endif /* not DOS_NT */
1413 if (nm
[0] == 0 || IS_DIRECTORY_SEP (nm
[0]))
1414 strcpy (target
, newdir
);
1417 file_name_as_directory (target
, newdir
);
1420 strcat (target
, nm
);
1422 if (index (target
, '/'))
1423 strcpy (target
, sys_translate_unix (target
));
1426 /* ASSERT (IS_DIRECTORY_SEP (target[0])) if not VMS */
1428 /* Now canonicalize by removing /. and /foo/.. if they appear. */
1436 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1442 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1443 /* brackets are offset from each other by 2 */
1446 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1447 /* convert [foo][bar] to [bar] */
1448 while (o
[-1] != '[' && o
[-1] != '<')
1450 else if (*p
== '-' && *o
!= '.')
1453 else if (p
[0] == '-' && o
[-1] == '.' &&
1454 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1455 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1459 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1460 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1462 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1464 /* else [foo.-] ==> [-] */
1470 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1471 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1477 if (!IS_DIRECTORY_SEP (*p
))
1481 else if (IS_DIRECTORY_SEP (p
[0])
1483 && (IS_DIRECTORY_SEP (p
[2])
1486 /* If "/." is the entire filename, keep the "/". Otherwise,
1487 just delete the whole "/.". */
1488 if (o
== target
&& p
[2] == '\0')
1492 else if (IS_DIRECTORY_SEP (p
[0]) && p
[1] == '.' && p
[2] == '.'
1493 /* `/../' is the "superroot" on certain file systems. */
1495 && (IS_DIRECTORY_SEP (p
[3]) || p
[3] == 0))
1497 while (o
!= target
&& (--o
) && !IS_DIRECTORY_SEP (*o
))
1499 /* Keep initial / only if this is the whole name. */
1500 if (o
== target
&& IS_ANY_SEP (*o
) && p
[3] == 0)
1508 #endif /* not VMS */
1512 /* At last, set drive name. */
1514 /* Except for network file name. */
1515 if (!(IS_DIRECTORY_SEP (target
[0]) && IS_DIRECTORY_SEP (target
[1])))
1516 #endif /* WINDOWSNT */
1518 if (!drive
) abort ();
1520 target
[0] = DRIVE_LETTER (drive
);
1523 CORRECT_DIR_SEPS (target
);
1526 return make_string (target
, o
- target
);
1530 /* Changed this DEFUN to a DEAFUN, so as not to confuse `make-docfile'. */
1531 DEAFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
1532 "Convert FILENAME to absolute, and canonicalize it.\n\
1533 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
1534 (does not start with slash); if DEFAULT is nil or missing,\n\
1535 the current buffer's value of default-directory is used.\n\
1536 Filenames containing `.' or `..' as components are simplified;\n\
1537 initial `~/' expands to your home directory.\n\
1538 See also the function `substitute-in-file-name'.")
1540 Lisp_Object name
, defalt
;
1544 register unsigned char *newdir
, *p
, *o
;
1546 unsigned char *target
;
1550 unsigned char * colon
= 0;
1551 unsigned char * close
= 0;
1552 unsigned char * slash
= 0;
1553 unsigned char * brack
= 0;
1554 int lbrack
= 0, rbrack
= 0;
1558 CHECK_STRING (name
, 0);
1561 /* Filenames on VMS are always upper case. */
1562 name
= Fupcase (name
);
1565 nm
= XSTRING (name
)->data
;
1567 /* If nm is absolute, flush ...// and detect /./ and /../.
1568 If no /./ or /../ we can return right away. */
1580 if (p
[0] == '/' && p
[1] == '/'
1582 /* // at start of filename is meaningful on Apollo system. */
1587 if (p
[0] == '/' && p
[1] == '~')
1588 nm
= p
+ 1, lose
= 1;
1589 if (p
[0] == '/' && p
[1] == '.'
1590 && (p
[2] == '/' || p
[2] == 0
1591 || (p
[2] == '.' && (p
[3] == '/' || p
[3] == 0))))
1597 /* if dev:[dir]/, move nm to / */
1598 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1599 nm
= (brack
? brack
+ 1 : colon
+ 1);
1600 lbrack
= rbrack
= 0;
1608 /* VMS pre V4.4,convert '-'s in filenames. */
1609 if (lbrack
== rbrack
)
1611 if (dots
< 2) /* this is to allow negative version numbers */
1616 if (lbrack
> rbrack
&&
1617 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1618 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1624 /* count open brackets, reset close bracket pointer */
1625 if (p
[0] == '[' || p
[0] == '<')
1626 lbrack
++, brack
= 0;
1627 /* count close brackets, set close bracket pointer */
1628 if (p
[0] == ']' || p
[0] == '>')
1629 rbrack
++, brack
= p
;
1630 /* detect ][ or >< */
1631 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1633 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1634 nm
= p
+ 1, lose
= 1;
1635 if (p
[0] == ':' && (colon
|| slash
))
1636 /* if dev1:[dir]dev2:, move nm to dev2: */
1642 /* If /name/dev:, move nm to dev: */
1645 /* If node::dev:, move colon following dev */
1646 else if (colon
&& colon
[-1] == ':')
1648 /* If dev1:dev2:, move nm to dev2: */
1649 else if (colon
&& colon
[-1] != ':')
1654 if (p
[0] == ':' && !colon
)
1660 if (lbrack
== rbrack
)
1663 else if (p
[0] == '.')
1671 if (index (nm
, '/'))
1672 return build_string (sys_translate_unix (nm
));
1674 if (nm
== XSTRING (name
)->data
)
1676 return build_string (nm
);
1680 /* Now determine directory to start with and put it in NEWDIR */
1684 if (nm
[0] == '~') /* prefix ~ */
1689 || nm
[1] == 0)/* ~/filename */
1691 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1692 newdir
= (unsigned char *) "";
1695 nm
++; /* Don't leave the slash in nm. */
1698 else /* ~user/filename */
1700 /* Get past ~ to user */
1701 unsigned char *user
= nm
+ 1;
1702 /* Find end of name. */
1703 unsigned char *ptr
= (unsigned char *) index (user
, '/');
1704 int len
= ptr
? ptr
- user
: strlen (user
);
1706 unsigned char *ptr1
= index (user
, ':');
1707 if (ptr1
!= 0 && ptr1
- user
< len
)
1710 /* Copy the user name into temp storage. */
1711 o
= (unsigned char *) alloca (len
+ 1);
1712 bcopy ((char *) user
, o
, len
);
1715 /* Look up the user name. */
1716 pw
= (struct passwd
*) getpwnam (o
+ 1);
1718 error ("\"%s\" isn't a registered user", o
+ 1);
1720 newdir
= (unsigned char *) pw
->pw_dir
;
1722 /* Discard the user name from NM. */
1729 #endif /* not VMS */
1733 defalt
= current_buffer
->directory
;
1734 CHECK_STRING (defalt
, 1);
1735 newdir
= XSTRING (defalt
)->data
;
1738 /* Now concatenate the directory and name to new space in the stack frame */
1740 tlen
= (newdir
? strlen (newdir
) + 1 : 0) + strlen (nm
) + 1;
1741 target
= (unsigned char *) alloca (tlen
);
1747 if (nm
[0] == 0 || nm
[0] == '/')
1748 strcpy (target
, newdir
);
1751 file_name_as_directory (target
, newdir
);
1754 strcat (target
, nm
);
1756 if (index (target
, '/'))
1757 strcpy (target
, sys_translate_unix (target
));
1760 /* Now canonicalize by removing /. and /foo/.. if they appear */
1768 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1774 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1775 /* brackets are offset from each other by 2 */
1778 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1779 /* convert [foo][bar] to [bar] */
1780 while (o
[-1] != '[' && o
[-1] != '<')
1782 else if (*p
== '-' && *o
!= '.')
1785 else if (p
[0] == '-' && o
[-1] == '.' &&
1786 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1787 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1791 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1792 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1794 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1796 /* else [foo.-] ==> [-] */
1802 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1803 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1813 else if (!strncmp (p
, "//", 2)
1815 /* // at start of filename is meaningful in Apollo system. */
1823 else if (p
[0] == '/' && p
[1] == '.' &&
1824 (p
[2] == '/' || p
[2] == 0))
1826 else if (!strncmp (p
, "/..", 3)
1827 /* `/../' is the "superroot" on certain file systems. */
1829 && (p
[3] == '/' || p
[3] == 0))
1831 while (o
!= target
&& *--o
!= '/')
1834 if (o
== target
+ 1 && o
[-1] == '/' && o
[0] == '/')
1838 if (o
== target
&& *o
== '/')
1846 #endif /* not VMS */
1849 return make_string (target
, o
- target
);
1853 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name
,
1854 Ssubstitute_in_file_name
, 1, 1, 0,
1855 "Substitute environment variables referred to in FILENAME.\n\
1856 `$FOO' where FOO is an environment variable name means to substitute\n\
1857 the value of that variable. The variable name should be terminated\n\
1858 with a character not a letter, digit or underscore; otherwise, enclose\n\
1859 the entire variable name in braces.\n\
1860 If `/~' appears, all of FILENAME through that `/' is discarded.\n\n\
1861 On VMS, `$' substitution is not done; this function does little and only\n\
1862 duplicates what `expand-file-name' does.")
1864 Lisp_Object filename
;
1868 register unsigned char *s
, *p
, *o
, *x
, *endp
;
1869 unsigned char *target
;
1871 int substituted
= 0;
1873 Lisp_Object handler
;
1875 CHECK_STRING (filename
, 0);
1877 /* If the file name has special constructs in it,
1878 call the corresponding file handler. */
1879 handler
= Ffind_file_name_handler (filename
, Qsubstitute_in_file_name
);
1880 if (!NILP (handler
))
1881 return call2 (handler
, Qsubstitute_in_file_name
, filename
);
1883 nm
= XSTRING (filename
)->data
;
1885 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
1886 CORRECT_DIR_SEPS (nm
);
1887 substituted
= (strcmp (nm
, XSTRING (filename
)->data
) != 0);
1889 endp
= nm
+ STRING_BYTES (XSTRING (filename
));
1891 /* If /~ or // appears, discard everything through first slash. */
1893 for (p
= nm
; p
!= endp
; p
++)
1896 #if defined (APOLLO) || defined (WINDOWSNT)
1897 /* // at start of file name is meaningful in Apollo and
1898 WindowsNT systems. */
1899 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != nm
)
1900 #else /* not (APOLLO || WINDOWSNT) */
1901 || IS_DIRECTORY_SEP (p
[0])
1902 #endif /* not (APOLLO || WINDOWSNT) */
1907 || p
[-1] == ':' || p
[-1] == ']' || p
[-1] == '>'
1909 || IS_DIRECTORY_SEP (p
[-1])))
1915 /* see comment in expand-file-name about drive specifiers */
1916 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
1917 && p
> nm
&& IS_DIRECTORY_SEP (p
[-1]))
1926 return build_string (nm
);
1929 /* See if any variables are substituted into the string
1930 and find the total length of their values in `total' */
1932 for (p
= nm
; p
!= endp
;)
1942 /* "$$" means a single "$" */
1951 while (p
!= endp
&& *p
!= '}') p
++;
1952 if (*p
!= '}') goto missingclose
;
1958 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1962 /* Copy out the variable name */
1963 target
= (unsigned char *) alloca (s
- o
+ 1);
1964 strncpy (target
, o
, s
- o
);
1967 strupr (target
); /* $home == $HOME etc. */
1970 /* Get variable value */
1971 o
= (unsigned char *) egetenv (target
);
1972 if (!o
) goto badvar
;
1973 total
+= strlen (o
);
1980 /* If substitution required, recopy the string and do it */
1981 /* Make space in stack frame for the new copy */
1982 xnm
= (unsigned char *) alloca (STRING_BYTES (XSTRING (filename
)) + total
+ 1);
1985 /* Copy the rest of the name through, replacing $ constructs with values */
2002 while (p
!= endp
&& *p
!= '}') p
++;
2003 if (*p
!= '}') goto missingclose
;
2009 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
2013 /* Copy out the variable name */
2014 target
= (unsigned char *) alloca (s
- o
+ 1);
2015 strncpy (target
, o
, s
- o
);
2018 strupr (target
); /* $home == $HOME etc. */
2021 /* Get variable value */
2022 o
= (unsigned char *) egetenv (target
);
2026 if (STRING_MULTIBYTE (filename
))
2028 /* If the original string is multibyte,
2029 convert what we substitute into multibyte. */
2030 unsigned char workbuf
[4], *str
;
2036 c
= unibyte_char_to_multibyte (c
);
2037 if (! SINGLE_BYTE_CHAR_P (c
))
2039 len
= CHAR_STRING (c
, workbuf
, str
);
2040 bcopy (str
, x
, len
);
2056 /* If /~ or // appears, discard everything through first slash. */
2058 for (p
= xnm
; p
!= x
; p
++)
2060 #if defined (APOLLO) || defined (WINDOWSNT)
2061 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != xnm
)
2062 #else /* not (APOLLO || WINDOWSNT) */
2063 || IS_DIRECTORY_SEP (p
[0])
2064 #endif /* not (APOLLO || WINDOWSNT) */
2066 && p
!= xnm
&& IS_DIRECTORY_SEP (p
[-1]))
2069 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
2070 && p
> nm
&& IS_DIRECTORY_SEP (p
[-1]))
2074 if (STRING_MULTIBYTE (filename
))
2075 return make_string (xnm
, x
- xnm
);
2076 return make_unibyte_string (xnm
, x
- xnm
);
2079 error ("Bad format environment-variable substitution");
2081 error ("Missing \"}\" in environment-variable substitution");
2083 error ("Substituting nonexistent environment variable \"%s\"", target
);
2086 #endif /* not VMS */
2089 /* A slightly faster and more convenient way to get
2090 (directory-file-name (expand-file-name FOO)). */
2093 expand_and_dir_to_file (filename
, defdir
)
2094 Lisp_Object filename
, defdir
;
2096 register Lisp_Object absname
;
2098 absname
= Fexpand_file_name (filename
, defdir
);
2101 register int c
= XSTRING (absname
)->data
[STRING_BYTES (XSTRING (absname
)) - 1];
2102 if (c
== ':' || c
== ']' || c
== '>')
2103 absname
= Fdirectory_file_name (absname
);
2106 /* Remove final slash, if any (unless this is the root dir).
2107 stat behaves differently depending! */
2108 if (XSTRING (absname
)->size
> 1
2109 && IS_DIRECTORY_SEP (XSTRING (absname
)->data
[STRING_BYTES (XSTRING (absname
)) - 1])
2110 && !IS_DEVICE_SEP (XSTRING (absname
)->data
[STRING_BYTES (XSTRING (absname
))-2]))
2111 /* We cannot take shortcuts; they might be wrong for magic file names. */
2112 absname
= Fdirectory_file_name (absname
);
2117 /* Signal an error if the file ABSNAME already exists.
2118 If INTERACTIVE is nonzero, ask the user whether to proceed,
2119 and bypass the error if the user says to go ahead.
2120 QUERYSTRING is a name for the action that is being considered
2123 *STATPTR is used to store the stat information if the file exists.
2124 If the file does not exist, STATPTR->st_mode is set to 0.
2125 If STATPTR is null, we don't store into it.
2127 If QUICK is nonzero, we ask for y or n, not yes or no. */
2130 barf_or_query_if_file_exists (absname
, querystring
, interactive
, statptr
, quick
)
2131 Lisp_Object absname
;
2132 unsigned char *querystring
;
2134 struct stat
*statptr
;
2137 register Lisp_Object tem
;
2138 struct stat statbuf
;
2139 struct gcpro gcpro1
;
2141 /* stat is a good way to tell whether the file exists,
2142 regardless of what access permissions it has. */
2143 if (stat (XSTRING (absname
)->data
, &statbuf
) >= 0)
2146 Fsignal (Qfile_already_exists
,
2147 Fcons (build_string ("File already exists"),
2148 Fcons (absname
, Qnil
)));
2150 tem
= format1 ("File %s already exists; %s anyway? ",
2151 XSTRING (absname
)->data
, querystring
);
2153 tem
= Fy_or_n_p (tem
);
2155 tem
= do_yes_or_no_p (tem
);
2158 Fsignal (Qfile_already_exists
,
2159 Fcons (build_string ("File already exists"),
2160 Fcons (absname
, Qnil
)));
2167 statptr
->st_mode
= 0;
2172 DEFUN ("copy-file", Fcopy_file
, Scopy_file
, 2, 4,
2173 "fCopy file: \nFCopy %s to file: \np\nP",
2174 "Copy FILE to NEWNAME. Both args must be strings.\n\
2175 Signals a `file-already-exists' error if file NEWNAME already exists,\n\
2176 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.\n\
2177 A number as third arg means request confirmation if NEWNAME already exists.\n\
2178 This is what happens in interactive use with M-x.\n\
2179 Fourth arg KEEP-TIME non-nil means give the new file the same\n\
2180 last-modified time as the old one. (This works on only some systems.)\n\
2181 A prefix arg makes KEEP-TIME non-nil.")
2182 (file
, newname
, ok_if_already_exists
, keep_date
)
2183 Lisp_Object file
, newname
, ok_if_already_exists
, keep_date
;
2186 char buf
[16 * 1024];
2187 struct stat st
, out_st
;
2188 Lisp_Object handler
;
2189 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2190 int count
= specpdl_ptr
- specpdl
;
2191 int input_file_statable_p
;
2192 Lisp_Object encoded_file
, encoded_newname
;
2194 encoded_file
= encoded_newname
= Qnil
;
2195 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2196 CHECK_STRING (file
, 0);
2197 CHECK_STRING (newname
, 1);
2199 file
= Fexpand_file_name (file
, Qnil
);
2200 newname
= Fexpand_file_name (newname
, Qnil
);
2202 /* If the input file name has special constructs in it,
2203 call the corresponding file handler. */
2204 handler
= Ffind_file_name_handler (file
, Qcopy_file
);
2205 /* Likewise for output file name. */
2207 handler
= Ffind_file_name_handler (newname
, Qcopy_file
);
2208 if (!NILP (handler
))
2209 RETURN_UNGCPRO (call5 (handler
, Qcopy_file
, file
, newname
,
2210 ok_if_already_exists
, keep_date
));
2212 encoded_file
= ENCODE_FILE (file
);
2213 encoded_newname
= ENCODE_FILE (newname
);
2215 if (NILP (ok_if_already_exists
)
2216 || INTEGERP (ok_if_already_exists
))
2217 barf_or_query_if_file_exists (encoded_newname
, "copy to it",
2218 INTEGERP (ok_if_already_exists
), &out_st
, 0);
2219 else if (stat (XSTRING (encoded_newname
)->data
, &out_st
) < 0)
2222 ifd
= open (XSTRING (encoded_file
)->data
, O_RDONLY
);
2224 report_file_error ("Opening input file", Fcons (file
, Qnil
));
2226 record_unwind_protect (close_file_unwind
, make_number (ifd
));
2228 /* We can only copy regular files and symbolic links. Other files are not
2230 input_file_statable_p
= (fstat (ifd
, &st
) >= 0);
2232 #if !defined (DOS_NT) || __DJGPP__ > 1
2233 if (out_st
.st_mode
!= 0
2234 && st
.st_dev
== out_st
.st_dev
&& st
.st_ino
== out_st
.st_ino
)
2237 report_file_error ("Input and output files are the same",
2238 Fcons (file
, Fcons (newname
, Qnil
)));
2242 #if defined (S_ISREG) && defined (S_ISLNK)
2243 if (input_file_statable_p
)
2245 if (!(S_ISREG (st
.st_mode
)) && !(S_ISLNK (st
.st_mode
)))
2247 #if defined (EISDIR)
2248 /* Get a better looking error message. */
2251 report_file_error ("Non-regular file", Fcons (file
, Qnil
));
2254 #endif /* S_ISREG && S_ISLNK */
2257 /* Create the copy file with the same record format as the input file */
2258 ofd
= sys_creat (XSTRING (encoded_newname
)->data
, 0666, ifd
);
2261 /* System's default file type was set to binary by _fmode in emacs.c. */
2262 ofd
= creat (XSTRING (encoded_newname
)->data
, S_IREAD
| S_IWRITE
);
2263 #else /* not MSDOS */
2264 ofd
= creat (XSTRING (encoded_newname
)->data
, 0666);
2265 #endif /* not MSDOS */
2268 report_file_error ("Opening output file", Fcons (newname
, Qnil
));
2270 record_unwind_protect (close_file_unwind
, make_number (ofd
));
2274 while ((n
= read (ifd
, buf
, sizeof buf
)) > 0)
2275 if (write (ofd
, buf
, n
) != n
)
2276 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2279 /* Closing the output clobbers the file times on some systems. */
2280 if (close (ofd
) < 0)
2281 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2283 if (input_file_statable_p
)
2285 if (!NILP (keep_date
))
2287 EMACS_TIME atime
, mtime
;
2288 EMACS_SET_SECS_USECS (atime
, st
.st_atime
, 0);
2289 EMACS_SET_SECS_USECS (mtime
, st
.st_mtime
, 0);
2290 if (set_file_times (XSTRING (encoded_newname
)->data
,
2292 Fsignal (Qfile_date_error
,
2293 Fcons (build_string ("Cannot set file date"),
2294 Fcons (newname
, Qnil
)));
2297 chmod (XSTRING (encoded_newname
)->data
, st
.st_mode
& 07777);
2299 #if defined (__DJGPP__) && __DJGPP__ > 1
2300 /* In DJGPP v2.0 and later, fstat usually returns true file mode bits,
2301 and if it can't, it tells so. Otherwise, under MSDOS we usually
2302 get only the READ bit, which will make the copied file read-only,
2303 so it's better not to chmod at all. */
2304 if ((_djstat_flags
& _STFAIL_WRITEBIT
) == 0)
2305 chmod (XSTRING (encoded_newname
)->data
, st
.st_mode
& 07777);
2306 #endif /* DJGPP version 2 or newer */
2312 /* Discard the unwind protects. */
2313 specpdl_ptr
= specpdl
+ count
;
2319 DEFUN ("make-directory-internal", Fmake_directory_internal
,
2320 Smake_directory_internal
, 1, 1, 0,
2321 "Create a new directory named DIRECTORY.")
2323 Lisp_Object directory
;
2326 Lisp_Object handler
;
2327 Lisp_Object encoded_dir
;
2329 CHECK_STRING (directory
, 0);
2330 directory
= Fexpand_file_name (directory
, Qnil
);
2332 handler
= Ffind_file_name_handler (directory
, Qmake_directory_internal
);
2333 if (!NILP (handler
))
2334 return call2 (handler
, Qmake_directory_internal
, directory
);
2336 encoded_dir
= ENCODE_FILE (directory
);
2338 dir
= XSTRING (encoded_dir
)->data
;
2341 if (mkdir (dir
) != 0)
2343 if (mkdir (dir
, 0777) != 0)
2345 report_file_error ("Creating directory", Flist (1, &directory
));
2350 DEFUN ("delete-directory", Fdelete_directory
, Sdelete_directory
, 1, 1, "FDelete directory: ",
2351 "Delete the directory named DIRECTORY.")
2353 Lisp_Object directory
;
2356 Lisp_Object handler
;
2357 Lisp_Object encoded_dir
;
2359 CHECK_STRING (directory
, 0);
2360 directory
= Fdirectory_file_name (Fexpand_file_name (directory
, Qnil
));
2362 handler
= Ffind_file_name_handler (directory
, Qdelete_directory
);
2363 if (!NILP (handler
))
2364 return call2 (handler
, Qdelete_directory
, directory
);
2366 encoded_dir
= ENCODE_FILE (directory
);
2368 dir
= XSTRING (encoded_dir
)->data
;
2370 if (rmdir (dir
) != 0)
2371 report_file_error ("Removing directory", Flist (1, &directory
));
2376 DEFUN ("delete-file", Fdelete_file
, Sdelete_file
, 1, 1, "fDelete file: ",
2377 "Delete file named FILENAME.\n\
2378 If file has multiple names, it continues to exist with the other names.")
2380 Lisp_Object filename
;
2382 Lisp_Object handler
;
2383 Lisp_Object encoded_file
;
2385 CHECK_STRING (filename
, 0);
2386 filename
= Fexpand_file_name (filename
, Qnil
);
2388 handler
= Ffind_file_name_handler (filename
, Qdelete_file
);
2389 if (!NILP (handler
))
2390 return call2 (handler
, Qdelete_file
, filename
);
2392 encoded_file
= ENCODE_FILE (filename
);
2394 if (0 > unlink (XSTRING (encoded_file
)->data
))
2395 report_file_error ("Removing old name", Flist (1, &filename
));
2400 internal_delete_file_1 (ignore
)
2406 /* Delete file FILENAME, returning 1 if successful and 0 if failed. */
2409 internal_delete_file (filename
)
2410 Lisp_Object filename
;
2412 return NILP (internal_condition_case_1 (Fdelete_file
, filename
,
2413 Qt
, internal_delete_file_1
));
2416 DEFUN ("rename-file", Frename_file
, Srename_file
, 2, 3,
2417 "fRename file: \nFRename %s to file: \np",
2418 "Rename FILE as NEWNAME. Both args strings.\n\
2419 If file has names other than FILE, it continues to have those names.\n\
2420 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2421 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2422 A number as third arg means request confirmation if NEWNAME already exists.\n\
2423 This is what happens in interactive use with M-x.")
2424 (file
, newname
, ok_if_already_exists
)
2425 Lisp_Object file
, newname
, ok_if_already_exists
;
2428 Lisp_Object args
[2];
2430 Lisp_Object handler
;
2431 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2432 Lisp_Object encoded_file
, encoded_newname
;
2434 encoded_file
= encoded_newname
= Qnil
;
2435 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2436 CHECK_STRING (file
, 0);
2437 CHECK_STRING (newname
, 1);
2438 file
= Fexpand_file_name (file
, Qnil
);
2439 newname
= Fexpand_file_name (newname
, Qnil
);
2441 /* If the file name has special constructs in it,
2442 call the corresponding file handler. */
2443 handler
= Ffind_file_name_handler (file
, Qrename_file
);
2445 handler
= Ffind_file_name_handler (newname
, Qrename_file
);
2446 if (!NILP (handler
))
2447 RETURN_UNGCPRO (call4 (handler
, Qrename_file
,
2448 file
, newname
, ok_if_already_exists
));
2450 encoded_file
= ENCODE_FILE (file
);
2451 encoded_newname
= ENCODE_FILE (newname
);
2453 if (NILP (ok_if_already_exists
)
2454 || INTEGERP (ok_if_already_exists
))
2455 barf_or_query_if_file_exists (encoded_newname
, "rename to it",
2456 INTEGERP (ok_if_already_exists
), 0, 0);
2458 if (0 > rename (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
))
2460 if (0 > link (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
)
2461 || 0 > unlink (XSTRING (encoded_file
)->data
))
2466 Fcopy_file (file
, newname
,
2467 /* We have already prompted if it was an integer,
2468 so don't have copy-file prompt again. */
2469 NILP (ok_if_already_exists
) ? Qnil
: Qt
, Qt
);
2470 Fdelete_file (file
);
2477 report_file_error ("Renaming", Flist (2, args
));
2480 report_file_error ("Renaming", Flist (2, &file
));
2487 DEFUN ("add-name-to-file", Fadd_name_to_file
, Sadd_name_to_file
, 2, 3,
2488 "fAdd name to file: \nFName to add to %s: \np",
2489 "Give FILE additional name NEWNAME. Both args strings.\n\
2490 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2491 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2492 A number as third arg means request confirmation if NEWNAME already exists.\n\
2493 This is what happens in interactive use with M-x.")
2494 (file
, newname
, ok_if_already_exists
)
2495 Lisp_Object file
, newname
, ok_if_already_exists
;
2498 Lisp_Object args
[2];
2500 Lisp_Object handler
;
2501 Lisp_Object encoded_file
, encoded_newname
;
2502 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2504 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2505 encoded_file
= encoded_newname
= Qnil
;
2506 CHECK_STRING (file
, 0);
2507 CHECK_STRING (newname
, 1);
2508 file
= Fexpand_file_name (file
, Qnil
);
2509 newname
= Fexpand_file_name (newname
, Qnil
);
2511 /* If the file name has special constructs in it,
2512 call the corresponding file handler. */
2513 handler
= Ffind_file_name_handler (file
, Qadd_name_to_file
);
2514 if (!NILP (handler
))
2515 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2516 newname
, ok_if_already_exists
));
2518 /* If the new name has special constructs in it,
2519 call the corresponding file handler. */
2520 handler
= Ffind_file_name_handler (newname
, Qadd_name_to_file
);
2521 if (!NILP (handler
))
2522 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2523 newname
, ok_if_already_exists
));
2525 encoded_file
= ENCODE_FILE (file
);
2526 encoded_newname
= ENCODE_FILE (newname
);
2528 if (NILP (ok_if_already_exists
)
2529 || INTEGERP (ok_if_already_exists
))
2530 barf_or_query_if_file_exists (encoded_newname
, "make it a new name",
2531 INTEGERP (ok_if_already_exists
), 0, 0);
2533 unlink (XSTRING (newname
)->data
);
2534 if (0 > link (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
))
2539 report_file_error ("Adding new name", Flist (2, args
));
2541 report_file_error ("Adding new name", Flist (2, &file
));
2550 DEFUN ("make-symbolic-link", Fmake_symbolic_link
, Smake_symbolic_link
, 2, 3,
2551 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np",
2552 "Make a symbolic link to FILENAME, named LINKNAME. Both args strings.\n\
2553 Signals a `file-already-exists' error if a file LINKNAME already exists\n\
2554 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2555 A number as third arg means request confirmation if LINKNAME already exists.\n\
2556 This happens for interactive use with M-x.")
2557 (filename
, linkname
, ok_if_already_exists
)
2558 Lisp_Object filename
, linkname
, ok_if_already_exists
;
2561 Lisp_Object args
[2];
2563 Lisp_Object handler
;
2564 Lisp_Object encoded_filename
, encoded_linkname
;
2565 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2567 GCPRO4 (filename
, linkname
, encoded_filename
, encoded_linkname
);
2568 encoded_filename
= encoded_linkname
= Qnil
;
2569 CHECK_STRING (filename
, 0);
2570 CHECK_STRING (linkname
, 1);
2571 /* If the link target has a ~, we must expand it to get
2572 a truly valid file name. Otherwise, do not expand;
2573 we want to permit links to relative file names. */
2574 if (XSTRING (filename
)->data
[0] == '~')
2575 filename
= Fexpand_file_name (filename
, Qnil
);
2576 linkname
= Fexpand_file_name (linkname
, Qnil
);
2578 /* If the file name has special constructs in it,
2579 call the corresponding file handler. */
2580 handler
= Ffind_file_name_handler (filename
, Qmake_symbolic_link
);
2581 if (!NILP (handler
))
2582 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2583 linkname
, ok_if_already_exists
));
2585 /* If the new link name has special constructs in it,
2586 call the corresponding file handler. */
2587 handler
= Ffind_file_name_handler (linkname
, Qmake_symbolic_link
);
2588 if (!NILP (handler
))
2589 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2590 linkname
, ok_if_already_exists
));
2592 encoded_filename
= ENCODE_FILE (filename
);
2593 encoded_linkname
= ENCODE_FILE (linkname
);
2595 if (NILP (ok_if_already_exists
)
2596 || INTEGERP (ok_if_already_exists
))
2597 barf_or_query_if_file_exists (encoded_linkname
, "make it a link",
2598 INTEGERP (ok_if_already_exists
), 0, 0);
2599 if (0 > symlink (XSTRING (encoded_filename
)->data
,
2600 XSTRING (encoded_linkname
)->data
))
2602 /* If we didn't complain already, silently delete existing file. */
2603 if (errno
== EEXIST
)
2605 unlink (XSTRING (encoded_linkname
)->data
);
2606 if (0 <= symlink (XSTRING (encoded_filename
)->data
,
2607 XSTRING (encoded_linkname
)->data
))
2617 report_file_error ("Making symbolic link", Flist (2, args
));
2619 report_file_error ("Making symbolic link", Flist (2, &filename
));
2625 #endif /* S_IFLNK */
2629 DEFUN ("define-logical-name", Fdefine_logical_name
, Sdefine_logical_name
,
2630 2, 2, "sDefine logical name: \nsDefine logical name %s as: ",
2631 "Define the job-wide logical name NAME to have the value STRING.\n\
2632 If STRING is nil or a null string, the logical name NAME is deleted.")
2637 CHECK_STRING (name
, 0);
2639 delete_logical_name (XSTRING (name
)->data
);
2642 CHECK_STRING (string
, 1);
2644 if (XSTRING (string
)->size
== 0)
2645 delete_logical_name (XSTRING (name
)->data
);
2647 define_logical_name (XSTRING (name
)->data
, XSTRING (string
)->data
);
2656 DEFUN ("sysnetunam", Fsysnetunam
, Ssysnetunam
, 2, 2, 0,
2657 "Open a network connection to PATH using LOGIN as the login string.")
2659 Lisp_Object path
, login
;
2663 CHECK_STRING (path
, 0);
2664 CHECK_STRING (login
, 0);
2666 netresult
= netunam (XSTRING (path
)->data
, XSTRING (login
)->data
);
2668 if (netresult
== -1)
2673 #endif /* HPUX_NET */
2675 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p
, Sfile_name_absolute_p
,
2677 "Return t if file FILENAME specifies an absolute file name.\n\
2678 On Unix, this is a name starting with a `/' or a `~'.")
2680 Lisp_Object filename
;
2684 CHECK_STRING (filename
, 0);
2685 ptr
= XSTRING (filename
)->data
;
2686 if (IS_DIRECTORY_SEP (*ptr
) || *ptr
== '~'
2688 /* ??? This criterion is probably wrong for '<'. */
2689 || index (ptr
, ':') || index (ptr
, '<')
2690 || (*ptr
== '[' && (ptr
[1] != '-' || (ptr
[2] != '.' && ptr
[2] != ']'))
2694 || (IS_DRIVE (*ptr
) && ptr
[1] == ':' && IS_DIRECTORY_SEP (ptr
[2]))
2702 /* Return nonzero if file FILENAME exists and can be executed. */
2705 check_executable (filename
)
2709 int len
= strlen (filename
);
2712 if (stat (filename
, &st
) < 0)
2714 #if defined (WINDOWSNT) || (defined (MSDOS) && __DJGPP__ > 1)
2715 return ((st
.st_mode
& S_IEXEC
) != 0);
2717 return (S_ISREG (st
.st_mode
)
2719 && (stricmp ((suffix
= filename
+ len
-4), ".com") == 0
2720 || stricmp (suffix
, ".exe") == 0
2721 || stricmp (suffix
, ".bat") == 0)
2722 || (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2723 #endif /* not WINDOWSNT */
2724 #else /* not DOS_NT */
2725 #ifdef HAVE_EUIDACCESS
2726 return (euidaccess (filename
, 1) >= 0);
2728 /* Access isn't quite right because it uses the real uid
2729 and we really want to test with the effective uid.
2730 But Unix doesn't give us a right way to do it. */
2731 return (access (filename
, 1) >= 0);
2733 #endif /* not DOS_NT */
2736 /* Return nonzero if file FILENAME exists and can be written. */
2739 check_writable (filename
)
2744 if (stat (filename
, &st
) < 0)
2746 return (st
.st_mode
& S_IWRITE
|| (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2747 #else /* not MSDOS */
2748 #ifdef HAVE_EUIDACCESS
2749 return (euidaccess (filename
, 2) >= 0);
2751 /* Access isn't quite right because it uses the real uid
2752 and we really want to test with the effective uid.
2753 But Unix doesn't give us a right way to do it.
2754 Opening with O_WRONLY could work for an ordinary file,
2755 but would lose for directories. */
2756 return (access (filename
, 2) >= 0);
2758 #endif /* not MSDOS */
2761 DEFUN ("file-exists-p", Ffile_exists_p
, Sfile_exists_p
, 1, 1, 0,
2762 "Return t if file FILENAME exists. (This does not mean you can read it.)\n\
2763 See also `file-readable-p' and `file-attributes'.")
2765 Lisp_Object filename
;
2767 Lisp_Object absname
;
2768 Lisp_Object handler
;
2769 struct stat statbuf
;
2771 CHECK_STRING (filename
, 0);
2772 absname
= Fexpand_file_name (filename
, Qnil
);
2774 /* If the file name has special constructs in it,
2775 call the corresponding file handler. */
2776 handler
= Ffind_file_name_handler (absname
, Qfile_exists_p
);
2777 if (!NILP (handler
))
2778 return call2 (handler
, Qfile_exists_p
, absname
);
2780 absname
= ENCODE_FILE (absname
);
2782 return (stat (XSTRING (absname
)->data
, &statbuf
) >= 0) ? Qt
: Qnil
;
2785 DEFUN ("file-executable-p", Ffile_executable_p
, Sfile_executable_p
, 1, 1, 0,
2786 "Return t if FILENAME can be executed by you.\n\
2787 For a directory, this means you can access files in that directory.")
2789 Lisp_Object filename
;
2792 Lisp_Object absname
;
2793 Lisp_Object handler
;
2795 CHECK_STRING (filename
, 0);
2796 absname
= Fexpand_file_name (filename
, Qnil
);
2798 /* If the file name has special constructs in it,
2799 call the corresponding file handler. */
2800 handler
= Ffind_file_name_handler (absname
, Qfile_executable_p
);
2801 if (!NILP (handler
))
2802 return call2 (handler
, Qfile_executable_p
, absname
);
2804 absname
= ENCODE_FILE (absname
);
2806 return (check_executable (XSTRING (absname
)->data
) ? Qt
: Qnil
);
2809 DEFUN ("file-readable-p", Ffile_readable_p
, Sfile_readable_p
, 1, 1, 0,
2810 "Return t if file FILENAME exists and you can read it.\n\
2811 See also `file-exists-p' and `file-attributes'.")
2813 Lisp_Object filename
;
2815 Lisp_Object absname
;
2816 Lisp_Object handler
;
2819 struct stat statbuf
;
2821 CHECK_STRING (filename
, 0);
2822 absname
= Fexpand_file_name (filename
, Qnil
);
2824 /* If the file name has special constructs in it,
2825 call the corresponding file handler. */
2826 handler
= Ffind_file_name_handler (absname
, Qfile_readable_p
);
2827 if (!NILP (handler
))
2828 return call2 (handler
, Qfile_readable_p
, absname
);
2830 absname
= ENCODE_FILE (absname
);
2833 /* Under MS-DOS and Windows, open does not work for directories. */
2834 if (access (XSTRING (absname
)->data
, 0) == 0)
2837 #else /* not DOS_NT */
2839 #if defined (S_ISFIFO) && defined (O_NONBLOCK)
2840 /* Opening a fifo without O_NONBLOCK can wait.
2841 We don't want to wait. But we don't want to mess wth O_NONBLOCK
2842 except in the case of a fifo, on a system which handles it. */
2843 desc
= stat (XSTRING (absname
)->data
, &statbuf
);
2846 if (S_ISFIFO (statbuf
.st_mode
))
2847 flags
|= O_NONBLOCK
;
2849 desc
= open (XSTRING (absname
)->data
, flags
);
2854 #endif /* not DOS_NT */
2857 /* Having this before file-symlink-p mysteriously caused it to be forgotten
2859 DEFUN ("file-writable-p", Ffile_writable_p
, Sfile_writable_p
, 1, 1, 0,
2860 "Return t if file FILENAME can be written or created by you.")
2862 Lisp_Object filename
;
2864 Lisp_Object absname
, dir
, encoded
;
2865 Lisp_Object handler
;
2866 struct stat statbuf
;
2868 CHECK_STRING (filename
, 0);
2869 absname
= Fexpand_file_name (filename
, Qnil
);
2871 /* If the file name has special constructs in it,
2872 call the corresponding file handler. */
2873 handler
= Ffind_file_name_handler (absname
, Qfile_writable_p
);
2874 if (!NILP (handler
))
2875 return call2 (handler
, Qfile_writable_p
, absname
);
2877 encoded
= ENCODE_FILE (absname
);
2878 if (stat (XSTRING (encoded
)->data
, &statbuf
) >= 0)
2879 return (check_writable (XSTRING (encoded
)->data
)
2882 dir
= Ffile_name_directory (absname
);
2885 dir
= Fdirectory_file_name (dir
);
2889 dir
= Fdirectory_file_name (dir
);
2892 dir
= ENCODE_FILE (dir
);
2893 return (check_writable (!NILP (dir
) ? (char *) XSTRING (dir
)->data
: "")
2897 DEFUN ("access-file", Faccess_file
, Saccess_file
, 2, 2, 0,
2898 "Access file FILENAME, and get an error if that does not work.\n\
2899 The second argument STRING is used in the error message.\n\
2900 If there is no error, we return nil.")
2902 Lisp_Object filename
, string
;
2904 Lisp_Object handler
, encoded_filename
;
2907 CHECK_STRING (filename
, 0);
2909 /* If the file name has special constructs in it,
2910 call the corresponding file handler. */
2911 handler
= Ffind_file_name_handler (filename
, Qaccess_file
);
2912 if (!NILP (handler
))
2913 return call3 (handler
, Qaccess_file
, filename
, string
);
2915 encoded_filename
= ENCODE_FILE (filename
);
2917 fd
= open (XSTRING (encoded_filename
)->data
, O_RDONLY
);
2919 report_file_error (XSTRING (string
)->data
, Fcons (filename
, Qnil
));
2925 DEFUN ("file-symlink-p", Ffile_symlink_p
, Sfile_symlink_p
, 1, 1, 0,
2926 "Return non-nil if file FILENAME is the name of a symbolic link.\n\
2927 The value is the name of the file to which it is linked.\n\
2928 Otherwise returns nil.")
2930 Lisp_Object filename
;
2937 Lisp_Object handler
;
2939 CHECK_STRING (filename
, 0);
2940 filename
= Fexpand_file_name (filename
, Qnil
);
2942 /* If the file name has special constructs in it,
2943 call the corresponding file handler. */
2944 handler
= Ffind_file_name_handler (filename
, Qfile_symlink_p
);
2945 if (!NILP (handler
))
2946 return call2 (handler
, Qfile_symlink_p
, filename
);
2948 filename
= ENCODE_FILE (filename
);
2953 buf
= (char *) xmalloc (bufsize
);
2954 bzero (buf
, bufsize
);
2955 valsize
= readlink (XSTRING (filename
)->data
, buf
, bufsize
);
2956 if (valsize
< bufsize
) break;
2957 /* Buffer was not long enough */
2966 val
= make_string (buf
, valsize
);
2968 val
= DECODE_FILE (val
);
2970 #else /* not S_IFLNK */
2972 #endif /* not S_IFLNK */
2975 DEFUN ("file-directory-p", Ffile_directory_p
, Sfile_directory_p
, 1, 1, 0,
2976 "Return t if FILENAME names an existing directory.")
2978 Lisp_Object filename
;
2980 register Lisp_Object absname
;
2982 Lisp_Object handler
;
2984 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2986 /* If the file name has special constructs in it,
2987 call the corresponding file handler. */
2988 handler
= Ffind_file_name_handler (absname
, Qfile_directory_p
);
2989 if (!NILP (handler
))
2990 return call2 (handler
, Qfile_directory_p
, absname
);
2992 absname
= ENCODE_FILE (absname
);
2994 if (stat (XSTRING (absname
)->data
, &st
) < 0)
2996 return (st
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
2999 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p
, Sfile_accessible_directory_p
, 1, 1, 0,
3000 "Return t if file FILENAME is the name of a directory as a file,\n\
3001 and files in that directory can be opened by you. In order to use a\n\
3002 directory as a buffer's current directory, this predicate must return true.\n\
3003 A directory name spec may be given instead; then the value is t\n\
3004 if the directory so specified exists and really is a readable and\n\
3005 searchable directory.")
3007 Lisp_Object filename
;
3009 Lisp_Object handler
;
3011 struct gcpro gcpro1
;
3013 /* If the file name has special constructs in it,
3014 call the corresponding file handler. */
3015 handler
= Ffind_file_name_handler (filename
, Qfile_accessible_directory_p
);
3016 if (!NILP (handler
))
3017 return call2 (handler
, Qfile_accessible_directory_p
, filename
);
3019 /* It's an unlikely combination, but yes we really do need to gcpro:
3020 Suppose that file-accessible-directory-p has no handler, but
3021 file-directory-p does have a handler; this handler causes a GC which
3022 relocates the string in `filename'; and finally file-directory-p
3023 returns non-nil. Then we would end up passing a garbaged string
3024 to file-executable-p. */
3026 tem
= (NILP (Ffile_directory_p (filename
))
3027 || NILP (Ffile_executable_p (filename
)));
3029 return tem
? Qnil
: Qt
;
3032 DEFUN ("file-regular-p", Ffile_regular_p
, Sfile_regular_p
, 1, 1, 0,
3033 "Return t if file FILENAME is the name of a regular file.\n\
3034 This is the sort of file that holds an ordinary stream of data bytes.")
3036 Lisp_Object filename
;
3038 register Lisp_Object absname
;
3040 Lisp_Object handler
;
3042 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
3044 /* If the file name has special constructs in it,
3045 call the corresponding file handler. */
3046 handler
= Ffind_file_name_handler (absname
, Qfile_regular_p
);
3047 if (!NILP (handler
))
3048 return call2 (handler
, Qfile_regular_p
, absname
);
3050 absname
= ENCODE_FILE (absname
);
3052 if (stat (XSTRING (absname
)->data
, &st
) < 0)
3054 return (st
.st_mode
& S_IFMT
) == S_IFREG
? Qt
: Qnil
;
3057 DEFUN ("file-modes", Ffile_modes
, Sfile_modes
, 1, 1, 0,
3058 "Return mode bits of file named FILENAME, as an integer.")
3060 Lisp_Object filename
;
3062 Lisp_Object absname
;
3064 Lisp_Object handler
;
3066 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
3068 /* If the file name has special constructs in it,
3069 call the corresponding file handler. */
3070 handler
= Ffind_file_name_handler (absname
, Qfile_modes
);
3071 if (!NILP (handler
))
3072 return call2 (handler
, Qfile_modes
, absname
);
3074 absname
= ENCODE_FILE (absname
);
3076 if (stat (XSTRING (absname
)->data
, &st
) < 0)
3078 #if defined (MSDOS) && __DJGPP__ < 2
3079 if (check_executable (XSTRING (absname
)->data
))
3080 st
.st_mode
|= S_IEXEC
;
3081 #endif /* MSDOS && __DJGPP__ < 2 */
3083 return make_number (st
.st_mode
& 07777);
3086 DEFUN ("set-file-modes", Fset_file_modes
, Sset_file_modes
, 2, 2, 0,
3087 "Set mode bits of file named FILENAME to MODE (an integer).\n\
3088 Only the 12 low bits of MODE are used.")
3090 Lisp_Object filename
, mode
;
3092 Lisp_Object absname
, encoded_absname
;
3093 Lisp_Object handler
;
3095 absname
= Fexpand_file_name (filename
, current_buffer
->directory
);
3096 CHECK_NUMBER (mode
, 1);
3098 /* If the file name has special constructs in it,
3099 call the corresponding file handler. */
3100 handler
= Ffind_file_name_handler (absname
, Qset_file_modes
);
3101 if (!NILP (handler
))
3102 return call3 (handler
, Qset_file_modes
, absname
, mode
);
3104 encoded_absname
= ENCODE_FILE (absname
);
3106 if (chmod (XSTRING (encoded_absname
)->data
, XINT (mode
)) < 0)
3107 report_file_error ("Doing chmod", Fcons (absname
, Qnil
));
3112 DEFUN ("set-default-file-modes", Fset_default_file_modes
, Sset_default_file_modes
, 1, 1, 0,
3113 "Set the file permission bits for newly created files.\n\
3114 The argument MODE should be an integer; only the low 9 bits are used.\n\
3115 This setting is inherited by subprocesses.")
3119 CHECK_NUMBER (mode
, 0);
3121 umask ((~ XINT (mode
)) & 0777);
3126 DEFUN ("default-file-modes", Fdefault_file_modes
, Sdefault_file_modes
, 0, 0, 0,
3127 "Return the default file protection for created files.\n\
3128 The value is an integer.")
3134 realmask
= umask (0);
3137 XSETINT (value
, (~ realmask
) & 0777);
3143 DEFUN ("unix-sync", Funix_sync
, Sunix_sync
, 0, 0, "",
3144 "Tell Unix to finish all pending disk updates.")
3153 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p
, Sfile_newer_than_file_p
, 2, 2, 0,
3154 "Return t if file FILE1 is newer than file FILE2.\n\
3155 If FILE1 does not exist, the answer is nil;\n\
3156 otherwise, if FILE2 does not exist, the answer is t.")
3158 Lisp_Object file1
, file2
;
3160 Lisp_Object absname1
, absname2
;
3163 Lisp_Object handler
;
3164 struct gcpro gcpro1
, gcpro2
;
3166 CHECK_STRING (file1
, 0);
3167 CHECK_STRING (file2
, 0);
3170 GCPRO2 (absname1
, file2
);
3171 absname1
= expand_and_dir_to_file (file1
, current_buffer
->directory
);
3172 absname2
= expand_and_dir_to_file (file2
, current_buffer
->directory
);
3175 /* If the file name has special constructs in it,
3176 call the corresponding file handler. */
3177 handler
= Ffind_file_name_handler (absname1
, Qfile_newer_than_file_p
);
3179 handler
= Ffind_file_name_handler (absname2
, Qfile_newer_than_file_p
);
3180 if (!NILP (handler
))
3181 return call3 (handler
, Qfile_newer_than_file_p
, absname1
, absname2
);
3183 GCPRO2 (absname1
, absname2
);
3184 absname1
= ENCODE_FILE (absname1
);
3185 absname2
= ENCODE_FILE (absname2
);
3188 if (stat (XSTRING (absname1
)->data
, &st
) < 0)
3191 mtime1
= st
.st_mtime
;
3193 if (stat (XSTRING (absname2
)->data
, &st
) < 0)
3196 return (mtime1
> st
.st_mtime
) ? Qt
: Qnil
;
3200 Lisp_Object Qfind_buffer_file_type
;
3203 #ifndef READ_BUF_SIZE
3204 #define READ_BUF_SIZE (64 << 10)
3207 DEFUN ("insert-file-contents", Finsert_file_contents
, Sinsert_file_contents
,
3209 "Insert contents of file FILENAME after point.\n\
3210 Returns list of absolute file name and number of bytes inserted.\n\
3211 If second argument VISIT is non-nil, the buffer's visited filename\n\
3212 and last save file modtime are set, and it is marked unmodified.\n\
3213 If visiting and the file does not exist, visiting is completed\n\
3214 before the error is signaled.\n\
3215 The optional third and fourth arguments BEG and END\n\
3216 specify what portion of the file to insert.\n\
3217 These arguments count bytes in the file, not characters in the buffer.\n\
3218 If VISIT is non-nil, BEG and END must be nil.\n\
3220 If optional fifth argument REPLACE is non-nil,\n\
3221 it means replace the current buffer contents (in the accessible portion)\n\
3222 with the file contents. This is better than simply deleting and inserting\n\
3223 the whole thing because (1) it preserves some marker positions\n\
3224 and (2) it puts less data in the undo list.\n\
3225 When REPLACE is non-nil, the value is the number of characters actually read,\n\
3226 which is often less than the number of characters to be read.\n\
3227 This does code conversion according to the value of\n\
3228 `coding-system-for-read' or `file-coding-system-alist',\n\
3229 and sets the variable `last-coding-system-used' to the coding system\n\
3231 (filename
, visit
, beg
, end
, replace
)
3232 Lisp_Object filename
, visit
, beg
, end
, replace
;
3237 register int how_much
;
3238 register int unprocessed
;
3239 int count
= specpdl_ptr
- specpdl
;
3240 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
3241 Lisp_Object handler
, val
, insval
, orig_filename
;
3244 int not_regular
= 0;
3245 char read_buf
[READ_BUF_SIZE
];
3246 struct coding_system coding
;
3247 unsigned char buffer
[1 << 14];
3248 int replace_handled
= 0;
3249 int set_coding_system
= 0;
3251 if (current_buffer
->base_buffer
&& ! NILP (visit
))
3252 error ("Cannot do file visiting in an indirect buffer");
3254 if (!NILP (current_buffer
->read_only
))
3255 Fbarf_if_buffer_read_only ();
3259 orig_filename
= Qnil
;
3261 GCPRO4 (filename
, val
, p
, orig_filename
);
3263 CHECK_STRING (filename
, 0);
3264 filename
= Fexpand_file_name (filename
, Qnil
);
3266 /* If the file name has special constructs in it,
3267 call the corresponding file handler. */
3268 handler
= Ffind_file_name_handler (filename
, Qinsert_file_contents
);
3269 if (!NILP (handler
))
3271 val
= call6 (handler
, Qinsert_file_contents
, filename
,
3272 visit
, beg
, end
, replace
);
3276 orig_filename
= filename
;
3277 filename
= ENCODE_FILE (filename
);
3282 if (stat (XSTRING (filename
)->data
, &st
) < 0)
3284 if ((fd
= open (XSTRING (filename
)->data
, O_RDONLY
)) < 0
3285 || fstat (fd
, &st
) < 0)
3286 #endif /* not APOLLO */
3288 if (fd
>= 0) close (fd
);
3291 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
3294 if (!NILP (Vcoding_system_for_read
))
3295 current_buffer
->buffer_file_coding_system
= Vcoding_system_for_read
;
3300 /* This code will need to be changed in order to work on named
3301 pipes, and it's probably just not worth it. So we should at
3302 least signal an error. */
3303 if (!S_ISREG (st
.st_mode
))
3310 if (! NILP (replace
) || ! NILP (beg
) || ! NILP (end
))
3311 Fsignal (Qfile_error
,
3312 Fcons (build_string ("not a regular file"),
3313 Fcons (orig_filename
, Qnil
)));
3318 if ((fd
= open (XSTRING (filename
)->data
, O_RDONLY
)) < 0)
3321 /* Replacement should preserve point as it preserves markers. */
3322 if (!NILP (replace
))
3323 record_unwind_protect (restore_point_unwind
, Fpoint_marker ());
3325 record_unwind_protect (close_file_unwind
, make_number (fd
));
3327 /* Supposedly happens on VMS. */
3328 if (! not_regular
&& st
.st_size
< 0)
3329 error ("File size is negative");
3331 if (!NILP (beg
) || !NILP (end
))
3333 error ("Attempt to visit less than an entire file");
3336 CHECK_NUMBER (beg
, 0);
3338 XSETFASTINT (beg
, 0);
3341 CHECK_NUMBER (end
, 0);
3346 XSETINT (end
, st
.st_size
);
3347 if (XINT (end
) != st
.st_size
)
3348 error ("Maximum buffer size exceeded");
3352 /* Decide the coding-system of the file. */
3354 Lisp_Object val
= Qnil
;
3356 if (!NILP (Vcoding_system_for_read
))
3357 val
= Vcoding_system_for_read
;
3360 if (! NILP (Vset_auto_coding_function
))
3362 /* Find a coding system specified in the heading two lines
3363 or in the tailing several lines of the file. We assume
3364 that the 1K-byte and 3K-byte for heading and tailing
3365 respectively are sufficient fot this purpose. */
3366 int how_many
, nread
;
3368 if (st
.st_size
<= (1024 * 4))
3369 nread
= read (fd
, read_buf
, 1024 * 4);
3372 nread
= read (fd
, read_buf
, 1024);
3375 if (lseek (fd
, st
.st_size
- (1024 * 3), 0) < 0)
3376 report_file_error ("Setting file position",
3377 Fcons (orig_filename
, Qnil
));
3378 nread
+= read (fd
, read_buf
+ nread
, 1024 * 3);
3383 error ("IO error reading %s: %s",
3384 XSTRING (orig_filename
)->data
, strerror (errno
));
3388 /* Always make this a unibyte string
3389 because we have not yet decoded it. */
3390 tem
= make_unibyte_string (read_buf
, nread
);
3391 val
= call1 (Vset_auto_coding_function
, tem
);
3392 /* Rewind the file for the actual read done later. */
3393 if (lseek (fd
, 0, 0) < 0)
3394 report_file_error ("Setting file position",
3395 Fcons (orig_filename
, Qnil
));
3400 Lisp_Object args
[6], coding_systems
;
3402 args
[0] = Qinsert_file_contents
, args
[1] = orig_filename
,
3403 args
[2] = visit
, args
[3] = beg
, args
[4] = end
, args
[5] = replace
;
3404 coding_systems
= Ffind_operation_coding_system (6, args
);
3405 if (CONSP (coding_systems
)) val
= XCONS (coding_systems
)->car
;
3409 if (NILP (Vcoding_system_for_read
)
3410 && NILP (current_buffer
->enable_multibyte_characters
))
3412 /* We must suppress all text conversion except for end-of-line
3414 struct coding_system coding_temp
;
3416 setup_coding_system (Fcheck_coding_system (val
), &coding_temp
);
3417 setup_coding_system (Qraw_text
, &coding
);
3418 coding
.eol_type
= coding_temp
.eol_type
;
3421 setup_coding_system (Fcheck_coding_system (val
), &coding
);
3424 /* If requested, replace the accessible part of the buffer
3425 with the file contents. Avoid replacing text at the
3426 beginning or end of the buffer that matches the file contents;
3427 that preserves markers pointing to the unchanged parts.
3429 Here we implement this feature in an optimized way
3430 for the case where code conversion is NOT needed.
3431 The following if-statement handles the case of conversion
3432 in a less optimal way.
3434 If the code conversion is "automatic" then we try using this
3435 method and hope for the best.
3436 But if we discover the need for conversion, we give up on this method
3437 and let the following if-statement handle the replace job. */
3439 && ! CODING_REQUIRE_DECODING (&coding
))
3441 /* same_at_start and same_at_end count bytes,
3442 because file access counts bytes
3443 and BEG and END count bytes. */
3444 int same_at_start
= BEGV_BYTE
;
3445 int same_at_end
= ZV_BYTE
;
3447 /* There is still a possibility we will find the need to do code
3448 conversion. If that happens, we set this variable to 1 to
3449 give up on handling REPLACE in the optimized way. */
3450 int giveup_match_end
= 0;
3452 if (XINT (beg
) != 0)
3454 if (lseek (fd
, XINT (beg
), 0) < 0)
3455 report_file_error ("Setting file position",
3456 Fcons (orig_filename
, Qnil
));
3461 /* Count how many chars at the start of the file
3462 match the text at the beginning of the buffer. */
3467 nread
= read (fd
, buffer
, sizeof buffer
);
3469 error ("IO error reading %s: %s",
3470 XSTRING (orig_filename
)->data
, strerror (errno
));
3471 else if (nread
== 0)
3474 if (coding
.type
== coding_type_undecided
)
3475 detect_coding (&coding
, buffer
, nread
);
3476 if (CODING_REQUIRE_DECODING (&coding
))
3477 /* We found that the file should be decoded somehow.
3478 Let's give up here. */
3480 giveup_match_end
= 1;
3484 if (coding
.eol_type
== CODING_EOL_UNDECIDED
)
3485 detect_eol (&coding
, buffer
, nread
);
3486 if (coding
.eol_type
!= CODING_EOL_UNDECIDED
3487 && coding
.eol_type
!= CODING_EOL_LF
)
3488 /* We found that the format of eol should be decoded.
3489 Let's give up here. */
3491 giveup_match_end
= 1;
3496 while (bufpos
< nread
&& same_at_start
< ZV_BYTE
3497 && FETCH_BYTE (same_at_start
) == buffer
[bufpos
])
3498 same_at_start
++, bufpos
++;
3499 /* If we found a discrepancy, stop the scan.
3500 Otherwise loop around and scan the next bufferful. */
3501 if (bufpos
!= nread
)
3505 /* If the file matches the buffer completely,
3506 there's no need to replace anything. */
3507 if (same_at_start
- BEGV_BYTE
== XINT (end
))
3511 /* Truncate the buffer to the size of the file. */
3512 del_range_1 (same_at_start
, same_at_end
, 0);
3517 /* Count how many chars at the end of the file
3518 match the text at the end of the buffer. But, if we have
3519 already found that decoding is necessary, don't waste time. */
3520 while (!giveup_match_end
)
3522 int total_read
, nread
, bufpos
, curpos
, trial
;
3524 /* At what file position are we now scanning? */
3525 curpos
= XINT (end
) - (ZV_BYTE
- same_at_end
);
3526 /* If the entire file matches the buffer tail, stop the scan. */
3529 /* How much can we scan in the next step? */
3530 trial
= min (curpos
, sizeof buffer
);
3531 if (lseek (fd
, curpos
- trial
, 0) < 0)
3532 report_file_error ("Setting file position",
3533 Fcons (orig_filename
, Qnil
));
3536 while (total_read
< trial
)
3538 nread
= read (fd
, buffer
+ total_read
, trial
- total_read
);
3540 error ("IO error reading %s: %s",
3541 XSTRING (orig_filename
)->data
, strerror (errno
));
3542 total_read
+= nread
;
3544 /* Scan this bufferful from the end, comparing with
3545 the Emacs buffer. */
3546 bufpos
= total_read
;
3547 /* Compare with same_at_start to avoid counting some buffer text
3548 as matching both at the file's beginning and at the end. */
3549 while (bufpos
> 0 && same_at_end
> same_at_start
3550 && FETCH_BYTE (same_at_end
- 1) == buffer
[bufpos
- 1])
3551 same_at_end
--, bufpos
--;
3553 /* If we found a discrepancy, stop the scan.
3554 Otherwise loop around and scan the preceding bufferful. */
3557 /* If this discrepancy is because of code conversion,
3558 we cannot use this method; giveup and try the other. */
3559 if (same_at_end
> same_at_start
3560 && FETCH_BYTE (same_at_end
- 1) >= 0200
3561 && ! NILP (current_buffer
->enable_multibyte_characters
)
3562 && (CODING_MAY_REQUIRE_DECODING (&coding
)))
3563 giveup_match_end
= 1;
3569 if (! giveup_match_end
)
3573 /* We win! We can handle REPLACE the optimized way. */
3575 /* Extends the end of non-matching text area to multibyte
3576 character boundary. */
3577 if (! NILP (current_buffer
->enable_multibyte_characters
))
3578 while (same_at_end
< ZV_BYTE
3579 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_end
)))
3582 /* Don't try to reuse the same piece of text twice. */
3583 overlap
= (same_at_start
- BEGV_BYTE
3584 - (same_at_end
+ st
.st_size
- ZV
));
3586 same_at_end
+= overlap
;
3588 /* Arrange to read only the nonmatching middle part of the file. */
3589 XSETFASTINT (beg
, XINT (beg
) + (same_at_start
- BEGV_BYTE
));
3590 XSETFASTINT (end
, XINT (end
) - (ZV_BYTE
- same_at_end
));
3592 del_range_byte (same_at_start
, same_at_end
, 0);
3593 /* Insert from the file at the proper position. */
3594 temp
= BYTE_TO_CHAR (same_at_start
);
3595 SET_PT_BOTH (temp
, same_at_start
);
3597 /* If display currently starts at beginning of line,
3598 keep it that way. */
3599 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3600 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3602 replace_handled
= 1;
3606 /* If requested, replace the accessible part of the buffer
3607 with the file contents. Avoid replacing text at the
3608 beginning or end of the buffer that matches the file contents;
3609 that preserves markers pointing to the unchanged parts.
3611 Here we implement this feature for the case where code conversion
3612 is needed, in a simple way that needs a lot of memory.
3613 The preceding if-statement handles the case of no conversion
3614 in a more optimized way. */
3615 if (!NILP (replace
) && ! replace_handled
)
3617 int same_at_start
= BEGV_BYTE
;
3618 int same_at_end
= ZV_BYTE
;
3621 /* Make sure that the gap is large enough. */
3622 int bufsize
= 2 * st
.st_size
;
3623 unsigned char *conversion_buffer
= (unsigned char *) xmalloc (bufsize
);
3626 /* First read the whole file, performing code conversion into
3627 CONVERSION_BUFFER. */
3629 if (lseek (fd
, XINT (beg
), 0) < 0)
3631 free (conversion_buffer
);
3632 report_file_error ("Setting file position",
3633 Fcons (orig_filename
, Qnil
));
3636 total
= st
.st_size
; /* Total bytes in the file. */
3637 how_much
= 0; /* Bytes read from file so far. */
3638 inserted
= 0; /* Bytes put into CONVERSION_BUFFER so far. */
3639 unprocessed
= 0; /* Bytes not processed in previous loop. */
3641 while (how_much
< total
)
3643 /* try is reserved in some compilers (Microsoft C) */
3644 int trytry
= min (total
- how_much
, READ_BUF_SIZE
- unprocessed
);
3645 char *destination
= read_buf
+ unprocessed
;
3648 /* Allow quitting out of the actual I/O. */
3651 this = read (fd
, destination
, trytry
);
3654 if (this < 0 || this + unprocessed
== 0)
3662 if (CODING_MAY_REQUIRE_DECODING (&coding
))
3664 int require
, result
;
3666 this += unprocessed
;
3668 /* If we are using more space than estimated,
3669 make CONVERSION_BUFFER bigger. */
3670 require
= decoding_buffer_size (&coding
, this);
3671 if (inserted
+ require
+ 2 * (total
- how_much
) > bufsize
)
3673 bufsize
= inserted
+ require
+ 2 * (total
- how_much
);
3674 conversion_buffer
= (unsigned char *) xrealloc (conversion_buffer
, bufsize
);
3677 /* Convert this batch with results in CONVERSION_BUFFER. */
3678 if (how_much
>= total
) /* This is the last block. */
3679 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
3680 result
= decode_coding (&coding
, read_buf
,
3681 conversion_buffer
+ inserted
,
3682 this, bufsize
- inserted
);
3684 /* Save for next iteration whatever we didn't convert. */
3685 unprocessed
= this - coding
.consumed
;
3686 bcopy (read_buf
+ coding
.consumed
, read_buf
, unprocessed
);
3687 this = coding
.produced
;
3693 /* At this point, INSERTED is how many characters (i.e. bytes)
3694 are present in CONVERSION_BUFFER.
3695 HOW_MUCH should equal TOTAL,
3696 or should be <= 0 if we couldn't read the file. */
3700 free (conversion_buffer
);
3703 error ("IO error reading %s: %s",
3704 XSTRING (orig_filename
)->data
, strerror (errno
));
3705 else if (how_much
== -2)
3706 error ("maximum buffer size exceeded");
3709 /* Compare the beginning of the converted file
3710 with the buffer text. */
3713 while (bufpos
< inserted
&& same_at_start
< same_at_end
3714 && FETCH_BYTE (same_at_start
) == conversion_buffer
[bufpos
])
3715 same_at_start
++, bufpos
++;
3717 /* If the file matches the buffer completely,
3718 there's no need to replace anything. */
3720 if (bufpos
== inserted
)
3722 free (conversion_buffer
);
3725 /* Truncate the buffer to the size of the file. */
3726 del_range_1 (same_at_start
, same_at_end
, 0);
3730 /* Scan this bufferful from the end, comparing with
3731 the Emacs buffer. */
3734 /* Compare with same_at_start to avoid counting some buffer text
3735 as matching both at the file's beginning and at the end. */
3736 while (bufpos
> 0 && same_at_end
> same_at_start
3737 && FETCH_BYTE (same_at_end
- 1) == conversion_buffer
[bufpos
- 1])
3738 same_at_end
--, bufpos
--;
3740 /* Don't try to reuse the same piece of text twice. */
3741 overlap
= same_at_start
- BEGV_BYTE
- (same_at_end
+ inserted
- ZV_BYTE
);
3743 same_at_end
+= overlap
;
3745 /* If display currently starts at beginning of line,
3746 keep it that way. */
3747 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3748 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3750 /* Replace the chars that we need to replace,
3751 and update INSERTED to equal the number of bytes
3752 we are taking from the file. */
3753 inserted
-= (Z_BYTE
- same_at_end
) + (same_at_start
- BEG_BYTE
);
3754 del_range_byte (same_at_start
, same_at_end
, 0);
3755 SET_PT_BOTH (GPT
, GPT_BYTE
);
3757 insert_1 (conversion_buffer
+ same_at_start
- BEG_BYTE
, inserted
,
3760 free (conversion_buffer
);
3769 register Lisp_Object temp
;
3771 total
= XINT (end
) - XINT (beg
);
3773 /* Make sure point-max won't overflow after this insertion. */
3774 XSETINT (temp
, total
);
3775 if (total
!= XINT (temp
))
3776 error ("Maximum buffer size exceeded");
3779 /* For a special file, all we can do is guess. */
3780 total
= READ_BUF_SIZE
;
3782 if (NILP (visit
) && total
> 0)
3783 prepare_to_modify_buffer (PT
, PT
, NULL
);
3786 if (GAP_SIZE
< total
)
3787 make_gap (total
- GAP_SIZE
);
3789 if (XINT (beg
) != 0 || !NILP (replace
))
3791 if (lseek (fd
, XINT (beg
), 0) < 0)
3792 report_file_error ("Setting file position",
3793 Fcons (orig_filename
, Qnil
));
3796 /* In the following loop, HOW_MUCH contains the total bytes read so
3797 far for a regular file, and not changed for a special file. But,
3798 before exiting the loop, it is set to a negative value if I/O
3801 /* Total bytes inserted. */
3803 /* Here, we don't do code conversion in the loop. It is done by
3804 code_convert_region after all data are read into the buffer. */
3805 while (how_much
< total
)
3807 /* try is reserved in some compilers (Microsoft C) */
3808 int trytry
= min (total
- how_much
, READ_BUF_SIZE
);
3811 /* For a special file, GAP_SIZE should be checked every time. */
3812 if (not_regular
&& GAP_SIZE
< trytry
)
3813 make_gap (total
- GAP_SIZE
);
3815 /* Allow quitting out of the actual I/O. */
3818 this = read (fd
, BYTE_POS_ADDR (PT_BYTE
+ inserted
- 1) + 1, trytry
);
3835 /* For a regular file, where TOTAL is the real size,
3836 count HOW_MUCH to compare with it.
3837 For a special file, where TOTAL is just a buffer size,
3838 so don't bother counting in HOW_MUCH.
3839 (INSERTED is where we count the number of characters inserted.) */
3846 /* Put an anchor to ensure multi-byte form ends at gap. */
3851 /* Discard the unwind protect for closing the file. */
3855 error ("IO error reading %s: %s",
3856 XSTRING (orig_filename
)->data
, strerror (errno
));
3860 if (CODING_MAY_REQUIRE_DECODING (&coding
))
3862 /* Here, we don't have to consider byte combining (see the
3863 comment below) because code_convert_region takes care of
3865 code_convert_region (PT
, PT_BYTE
, PT
+ inserted
, PT_BYTE
+ inserted
,
3867 inserted
= (NILP (current_buffer
->enable_multibyte_characters
)
3868 ? coding
.produced
: coding
.produced_char
);
3870 else if (!NILP (current_buffer
->enable_multibyte_characters
))
3872 int inserted_byte
= inserted
;
3874 /* There's a possibility that we must combine bytes at the
3875 head (resp. the tail) of the just inserted text with the
3876 bytes before (resp. after) the gap to form a single
3878 inserted
= multibyte_chars_in_text (GPT_ADDR
- inserted
, inserted
);
3879 adjust_after_insert (PT
, PT_BYTE
,
3880 PT
+ inserted_byte
, PT_BYTE
+ inserted_byte
,
3884 adjust_after_insert (PT
, PT_BYTE
, PT
+ inserted
, PT_BYTE
+ inserted
,
3888 /* Use the conversion type to determine buffer-file-type
3889 (find-buffer-file-type is now used to help determine the
3891 if (coding
.eol_type
!= CODING_EOL_UNDECIDED
3892 && coding
.eol_type
!= CODING_EOL_LF
)
3893 current_buffer
->buffer_file_type
= Qnil
;
3895 current_buffer
->buffer_file_type
= Qt
;
3899 set_coding_system
= 1;
3906 if (!EQ (current_buffer
->undo_list
, Qt
))
3907 current_buffer
->undo_list
= Qnil
;
3909 stat (XSTRING (filename
)->data
, &st
);
3914 current_buffer
->modtime
= st
.st_mtime
;
3915 current_buffer
->filename
= orig_filename
;
3918 SAVE_MODIFF
= MODIFF
;
3919 current_buffer
->auto_save_modified
= MODIFF
;
3920 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
3921 #ifdef CLASH_DETECTION
3924 if (!NILP (current_buffer
->file_truename
))
3925 unlock_file (current_buffer
->file_truename
);
3926 unlock_file (filename
);
3928 #endif /* CLASH_DETECTION */
3930 Fsignal (Qfile_error
,
3931 Fcons (build_string ("not a regular file"),
3932 Fcons (orig_filename
, Qnil
)));
3934 /* If visiting nonexistent file, return nil. */
3935 if (current_buffer
->modtime
== -1)
3936 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
3939 /* Decode file format */
3942 insval
= call3 (Qformat_decode
,
3943 Qnil
, make_number (inserted
), visit
);
3944 CHECK_NUMBER (insval
, 0);
3945 inserted
= XFASTINT (insval
);
3948 /* Call after-change hooks for the inserted text, aside from the case
3949 of normal visiting (not with REPLACE), which is done in a new buffer
3950 "before" the buffer is changed. */
3951 if (inserted
> 0 && total
> 0
3952 && (NILP (visit
) || !NILP (replace
)))
3953 signal_after_change (PT
, 0, inserted
);
3955 if (set_coding_system
)
3956 Vlast_coding_system_used
= coding
.symbol
;
3960 p
= Vafter_insert_file_functions
;
3963 insval
= call1 (Fcar (p
), make_number (inserted
));
3966 CHECK_NUMBER (insval
, 0);
3967 inserted
= XFASTINT (insval
);
3974 /* ??? Retval needs to be dealt with in all cases consistently. */
3976 val
= Fcons (orig_filename
,
3977 Fcons (make_number (inserted
),
3980 RETURN_UNGCPRO (unbind_to (count
, val
));
3983 static Lisp_Object build_annotations
P_ ((Lisp_Object
, Lisp_Object
,
3986 /* If build_annotations switched buffers, switch back to BUF.
3987 Kill the temporary buffer that was selected in the meantime.
3989 Since this kill only the last temporary buffer, some buffers remain
3990 not killed if build_annotations switched buffers more than once.
3994 build_annotations_unwind (buf
)
3999 if (XBUFFER (buf
) == current_buffer
)
4001 tembuf
= Fcurrent_buffer ();
4003 Fkill_buffer (tembuf
);
4007 DEFUN ("write-region", Fwrite_region
, Swrite_region
, 3, 7,
4008 "r\nFWrite region to file: \ni\ni\ni\np",
4009 "Write current region into specified file.\n\
4010 When called from a program, takes three arguments:\n\
4011 START, END and FILENAME. START and END are buffer positions.\n\
4012 Optional fourth argument APPEND if non-nil means\n\
4013 append to existing file contents (if any).\n\
4014 Optional fifth argument VISIT if t means\n\
4015 set the last-save-file-modtime of buffer to this file's modtime\n\
4016 and mark buffer not modified.\n\
4017 If VISIT is a string, it is a second file name;\n\
4018 the output goes to FILENAME, but the buffer is marked as visiting VISIT.\n\
4019 VISIT is also the file name to lock and unlock for clash detection.\n\
4020 If VISIT is neither t nor nil nor a string,\n\
4021 that means do not print the \"Wrote file\" message.\n\
4022 The optional sixth arg LOCKNAME, if non-nil, specifies the name to\n\
4023 use for locking and unlocking, overriding FILENAME and VISIT.\n\
4024 The optional seventh arg CONFIRM, if non-nil, says ask for confirmation\n\
4025 before overwriting an existing file.\n\
4026 Kludgy feature: if START is a string, then that string is written\n\
4027 to the file, instead of any buffer contents, and END is ignored.")
4028 (start
, end
, filename
, append
, visit
, lockname
, confirm
)
4029 Lisp_Object start
, end
, filename
, append
, visit
, lockname
, confirm
;
4037 int count
= specpdl_ptr
- specpdl
;
4040 unsigned char *fname
= 0; /* If non-0, original filename (must rename) */
4042 Lisp_Object handler
;
4043 Lisp_Object visit_file
;
4044 Lisp_Object annotations
;
4045 Lisp_Object encoded_filename
;
4046 int visiting
, quietly
;
4047 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
4048 struct buffer
*given_buffer
;
4050 int buffer_file_type
= O_BINARY
;
4052 struct coding_system coding
;
4054 if (current_buffer
->base_buffer
&& ! NILP (visit
))
4055 error ("Cannot do file visiting in an indirect buffer");
4057 if (!NILP (start
) && !STRINGP (start
))
4058 validate_region (&start
, &end
);
4060 GCPRO4 (start
, filename
, visit
, lockname
);
4062 /* Decide the coding-system to encode the data with. */
4068 else if (!NILP (Vcoding_system_for_write
))
4069 val
= Vcoding_system_for_write
;
4070 else if (NILP (current_buffer
->enable_multibyte_characters
))
4072 /* If the variable `buffer-file-coding-system' is set locally,
4073 it means that the file was read with some kind of code
4074 conversion or the varialbe is explicitely set by users. We
4075 had better write it out with the same coding system even if
4076 `enable-multibyte-characters' is nil.
4078 If it is not set locally, we anyway have to convert EOL
4079 format if the default value of `buffer-file-coding-system'
4080 tells that it is not Unix-like (LF only) format. */
4081 val
= current_buffer
->buffer_file_coding_system
;
4082 if (NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4084 struct coding_system coding_temp
;
4086 setup_coding_system (Fcheck_coding_system (val
), &coding_temp
);
4087 if (coding_temp
.eol_type
== CODING_EOL_CRLF
4088 || coding_temp
.eol_type
== CODING_EOL_CR
)
4090 setup_coding_system (Qraw_text
, &coding
);
4091 coding
.eol_type
= coding_temp
.eol_type
;
4092 goto done_setup_coding
;
4099 Lisp_Object args
[7], coding_systems
;
4101 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4102 args
[3] = filename
; args
[4] = append
; args
[5] = visit
;
4104 coding_systems
= Ffind_operation_coding_system (7, args
);
4105 val
= (CONSP (coding_systems
) && !NILP (XCONS (coding_systems
)->cdr
)
4106 ? XCONS (coding_systems
)->cdr
4107 : current_buffer
->buffer_file_coding_system
);
4108 /* Confirm that VAL can surely encode the current region. */
4109 if (!NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4110 val
= call3 (Vselect_safe_coding_system_function
, start
, end
, val
);
4112 setup_coding_system (Fcheck_coding_system (val
), &coding
);
4115 if (!STRINGP (start
) && !NILP (current_buffer
->selective_display
))
4116 coding
.mode
|= CODING_MODE_SELECTIVE_DISPLAY
;
4119 Vlast_coding_system_used
= coding
.symbol
;
4121 filename
= Fexpand_file_name (filename
, Qnil
);
4123 if (! NILP (confirm
))
4124 barf_or_query_if_file_exists (filename
, "overwrite", 1, 0, 1);
4126 if (STRINGP (visit
))
4127 visit_file
= Fexpand_file_name (visit
, Qnil
);
4129 visit_file
= filename
;
4132 visiting
= (EQ (visit
, Qt
) || STRINGP (visit
));
4133 quietly
= !NILP (visit
);
4137 if (NILP (lockname
))
4138 lockname
= visit_file
;
4140 GCPRO5 (start
, filename
, annotations
, visit_file
, lockname
);
4142 /* If the file name has special constructs in it,
4143 call the corresponding file handler. */
4144 handler
= Ffind_file_name_handler (filename
, Qwrite_region
);
4145 /* If FILENAME has no handler, see if VISIT has one. */
4146 if (NILP (handler
) && STRINGP (visit
))
4147 handler
= Ffind_file_name_handler (visit
, Qwrite_region
);
4149 if (!NILP (handler
))
4152 val
= call6 (handler
, Qwrite_region
, start
, end
,
4153 filename
, append
, visit
);
4157 SAVE_MODIFF
= MODIFF
;
4158 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4159 current_buffer
->filename
= visit_file
;
4165 /* Special kludge to simplify auto-saving. */
4168 XSETFASTINT (start
, BEG
);
4169 XSETFASTINT (end
, Z
);
4172 record_unwind_protect (build_annotations_unwind
, Fcurrent_buffer ());
4173 count1
= specpdl_ptr
- specpdl
;
4175 given_buffer
= current_buffer
;
4176 annotations
= build_annotations (start
, end
, coding
.pre_write_conversion
);
4177 if (current_buffer
!= given_buffer
)
4179 XSETFASTINT (start
, BEGV
);
4180 XSETFASTINT (end
, ZV
);
4183 #ifdef CLASH_DETECTION
4186 #if 0 /* This causes trouble for GNUS. */
4187 /* If we've locked this file for some other buffer,
4188 query before proceeding. */
4189 if (!visiting
&& EQ (Ffile_locked_p (lockname
), Qt
))
4190 call2 (intern ("ask-user-about-lock"), filename
, Vuser_login_name
);
4193 lock_file (lockname
);
4195 #endif /* CLASH_DETECTION */
4197 encoded_filename
= ENCODE_FILE (filename
);
4199 fn
= XSTRING (encoded_filename
)->data
;
4203 desc
= open (fn
, O_WRONLY
| buffer_file_type
);
4204 #else /* not DOS_NT */
4205 desc
= open (fn
, O_WRONLY
);
4206 #endif /* not DOS_NT */
4208 if (desc
< 0 && (NILP (append
) || errno
== ENOENT
))
4210 if (auto_saving
) /* Overwrite any previous version of autosave file */
4212 vms_truncate (fn
); /* if fn exists, truncate to zero length */
4213 desc
= open (fn
, O_RDWR
);
4215 desc
= creat_copy_attrs (STRINGP (current_buffer
->filename
)
4216 ? XSTRING (current_buffer
->filename
)->data
: 0,
4219 else /* Write to temporary name and rename if no errors */
4221 Lisp_Object temp_name
;
4222 temp_name
= Ffile_name_directory (filename
);
4224 if (!NILP (temp_name
))
4226 temp_name
= Fmake_temp_name (concat2 (temp_name
,
4227 build_string ("$$SAVE$$")));
4228 fname
= XSTRING (filename
)->data
;
4229 fn
= XSTRING (temp_name
)->data
;
4230 desc
= creat_copy_attrs (fname
, fn
);
4233 /* If we can't open the temporary file, try creating a new
4234 version of the original file. VMS "creat" creates a
4235 new version rather than truncating an existing file. */
4238 desc
= creat (fn
, 0666);
4239 #if 0 /* This can clobber an existing file and fail to replace it,
4240 if the user runs out of space. */
4243 /* We can't make a new version;
4244 try to truncate and rewrite existing version if any. */
4246 desc
= open (fn
, O_RDWR
);
4252 desc
= creat (fn
, 0666);
4257 O_WRONLY
| O_TRUNC
| O_CREAT
| buffer_file_type
,
4258 S_IREAD
| S_IWRITE
);
4259 #else /* not DOS_NT */
4260 desc
= creat (fn
, auto_saving
? auto_save_mode_bits
: 0666);
4261 #endif /* not DOS_NT */
4262 #endif /* not VMS */
4268 #ifdef CLASH_DETECTION
4270 if (!auto_saving
) unlock_file (lockname
);
4272 #endif /* CLASH_DETECTION */
4273 report_file_error ("Opening output file", Fcons (filename
, Qnil
));
4276 record_unwind_protect (close_file_unwind
, make_number (desc
));
4279 if (lseek (desc
, 0, 2) < 0)
4281 #ifdef CLASH_DETECTION
4282 if (!auto_saving
) unlock_file (lockname
);
4283 #endif /* CLASH_DETECTION */
4284 report_file_error ("Lseek error", Fcons (filename
, Qnil
));
4289 * Kludge Warning: The VMS C RTL likes to insert carriage returns
4290 * if we do writes that don't end with a carriage return. Furthermore
4291 * it cannot handle writes of more then 16K. The modified
4292 * version of "sys_write" in SYSDEP.C (see comment there) copes with
4293 * this EXCEPT for the last record (iff it doesn't end with a carriage
4294 * return). This implies that if your buffer doesn't end with a carriage
4295 * return, you get one free... tough. However it also means that if
4296 * we make two calls to sys_write (a la the following code) you can
4297 * get one at the gap as well. The easiest way to fix this (honest)
4298 * is to move the gap to the next newline (or the end of the buffer).
4303 if (GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4304 move_gap (find_next_newline (GPT
, 1));
4306 /* Whether VMS or not, we must move the gap to the next of newline
4307 when we must put designation sequences at beginning of line. */
4308 if (INTEGERP (start
)
4309 && coding
.type
== coding_type_iso2022
4310 && coding
.flags
& CODING_FLAG_ISO_DESIGNATE_AT_BOL
4311 && GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4313 int opoint
= PT
, opoint_byte
= PT_BYTE
;
4314 scan_newline (PT
, PT_BYTE
, ZV
, ZV_BYTE
, 1, 0);
4315 move_gap_both (PT
, PT_BYTE
);
4316 SET_PT_BOTH (opoint
, opoint_byte
);
4323 if (STRINGP (start
))
4325 failure
= 0 > a_write (desc
, XSTRING (start
)->data
,
4326 STRING_BYTES (XSTRING (start
)), 0, &annotations
,
4330 else if (XINT (start
) != XINT (end
))
4332 register int end1
= CHAR_TO_BYTE (XINT (end
));
4334 tem
= CHAR_TO_BYTE (XINT (start
));
4336 if (XINT (start
) < GPT
)
4338 failure
= 0 > a_write (desc
, BYTE_POS_ADDR (tem
),
4339 min (GPT_BYTE
, end1
) - tem
, tem
, &annotations
,
4344 if (XINT (end
) > GPT
&& !failure
)
4346 tem
= max (tem
, GPT_BYTE
);
4347 failure
= 0 > a_write (desc
, BYTE_POS_ADDR (tem
), end1
- tem
,
4348 tem
, &annotations
, &coding
);
4354 /* If file was empty, still need to write the annotations */
4355 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4356 failure
= 0 > a_write (desc
, "", 0, XINT (start
), &annotations
, &coding
);
4360 if (CODING_REQUIRE_FLUSHING (&coding
)
4361 && !(coding
.mode
& CODING_MODE_LAST_BLOCK
)
4364 /* We have to flush out a data. */
4365 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4366 failure
= 0 > e_write (desc
, "", 0, &coding
);
4373 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
4374 Disk full in NFS may be reported here. */
4375 /* mib says that closing the file will try to write as fast as NFS can do
4376 it, and that means the fsync here is not crucial for autosave files. */
4377 if (!auto_saving
&& fsync (desc
) < 0)
4379 /* If fsync fails with EINTR, don't treat that as serious. */
4381 failure
= 1, save_errno
= errno
;
4385 /* Spurious "file has changed on disk" warnings have been
4386 observed on Suns as well.
4387 It seems that `close' can change the modtime, under nfs.
4389 (This has supposedly been fixed in Sunos 4,
4390 but who knows about all the other machines with NFS?) */
4393 /* On VMS and APOLLO, must do the stat after the close
4394 since closing changes the modtime. */
4397 /* Recall that #if defined does not work on VMS. */
4404 /* NFS can report a write failure now. */
4405 if (close (desc
) < 0)
4406 failure
= 1, save_errno
= errno
;
4409 /* If we wrote to a temporary name and had no errors, rename to real name. */
4413 failure
= (rename (fn
, fname
) != 0), save_errno
= errno
;
4421 /* Discard the unwind protect for close_file_unwind. */
4422 specpdl_ptr
= specpdl
+ count1
;
4423 /* Restore the original current buffer. */
4424 visit_file
= unbind_to (count
, visit_file
);
4426 #ifdef CLASH_DETECTION
4428 unlock_file (lockname
);
4429 #endif /* CLASH_DETECTION */
4431 /* Do this before reporting IO error
4432 to avoid a "file has changed on disk" warning on
4433 next attempt to save. */
4435 current_buffer
->modtime
= st
.st_mtime
;
4438 error ("IO error writing %s: %s", XSTRING (filename
)->data
,
4439 strerror (save_errno
));
4443 SAVE_MODIFF
= MODIFF
;
4444 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4445 current_buffer
->filename
= visit_file
;
4446 update_mode_lines
++;
4452 message_with_string ("Wrote %s", visit_file
, 1);
4457 Lisp_Object
merge ();
4459 DEFUN ("car-less-than-car", Fcar_less_than_car
, Scar_less_than_car
, 2, 2, 0,
4460 "Return t if (car A) is numerically less than (car B).")
4464 return Flss (Fcar (a
), Fcar (b
));
4467 /* Build the complete list of annotations appropriate for writing out
4468 the text between START and END, by calling all the functions in
4469 write-region-annotate-functions and merging the lists they return.
4470 If one of these functions switches to a different buffer, we assume
4471 that buffer contains altered text. Therefore, the caller must
4472 make sure to restore the current buffer in all cases,
4473 as save-excursion would do. */
4476 build_annotations (start
, end
, pre_write_conversion
)
4477 Lisp_Object start
, end
, pre_write_conversion
;
4479 Lisp_Object annotations
;
4481 struct gcpro gcpro1
, gcpro2
;
4482 Lisp_Object original_buffer
;
4484 XSETBUFFER (original_buffer
, current_buffer
);
4487 p
= Vwrite_region_annotate_functions
;
4488 GCPRO2 (annotations
, p
);
4491 struct buffer
*given_buffer
= current_buffer
;
4492 Vwrite_region_annotations_so_far
= annotations
;
4493 res
= call2 (Fcar (p
), start
, end
);
4494 /* If the function makes a different buffer current,
4495 assume that means this buffer contains altered text to be output.
4496 Reset START and END from the buffer bounds
4497 and discard all previous annotations because they should have
4498 been dealt with by this function. */
4499 if (current_buffer
!= given_buffer
)
4501 XSETFASTINT (start
, BEGV
);
4502 XSETFASTINT (end
, ZV
);
4505 Flength (res
); /* Check basic validity of return value */
4506 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
4510 /* Now do the same for annotation functions implied by the file-format */
4511 if (auto_saving
&& (!EQ (Vauto_save_file_format
, Qt
)))
4512 p
= Vauto_save_file_format
;
4514 p
= current_buffer
->file_format
;
4517 struct buffer
*given_buffer
= current_buffer
;
4518 Vwrite_region_annotations_so_far
= annotations
;
4519 res
= call4 (Qformat_annotate_function
, Fcar (p
), start
, end
,
4521 if (current_buffer
!= given_buffer
)
4523 XSETFASTINT (start
, BEGV
);
4524 XSETFASTINT (end
, ZV
);
4528 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
4532 /* At last, do the same for the function PRE_WRITE_CONVERSION
4533 implied by the current coding-system. */
4534 if (!NILP (pre_write_conversion
))
4536 struct buffer
*given_buffer
= current_buffer
;
4537 Vwrite_region_annotations_so_far
= annotations
;
4538 res
= call2 (pre_write_conversion
, start
, end
);
4540 annotations
= (current_buffer
!= given_buffer
4542 : merge (annotations
, res
, Qcar_less_than_car
));
4549 /* Write to descriptor DESC the NBYTES bytes starting at ADDR,
4550 assuming they start at byte position BYTEPOS in the buffer.
4551 Intersperse with them the annotations from *ANNOT
4552 which fall within the range of byte positions BYTEPOS to BYTEPOS + NBYTES,
4553 each at its appropriate position.
4555 We modify *ANNOT by discarding elements as we use them up.
4557 The return value is negative in case of system call failure. */
4560 a_write (desc
, addr
, nbytes
, bytepos
, annot
, coding
)
4562 register char *addr
;
4563 register int nbytes
;
4566 struct coding_system
*coding
;
4570 int lastpos
= bytepos
+ nbytes
;
4572 while (NILP (*annot
) || CONSP (*annot
))
4574 tem
= Fcar_safe (Fcar (*annot
));
4575 nextpos
= bytepos
- 1;
4577 nextpos
= CHAR_TO_BYTE (XFASTINT (tem
));
4579 /* If there are no more annotations in this range,
4580 output the rest of the range all at once. */
4581 if (! (nextpos
>= bytepos
&& nextpos
<= lastpos
))
4582 return e_write (desc
, addr
, lastpos
- bytepos
, coding
);
4584 /* Output buffer text up to the next annotation's position. */
4585 if (nextpos
> bytepos
)
4587 if (0 > e_write (desc
, addr
, nextpos
- bytepos
, coding
))
4589 addr
+= nextpos
- bytepos
;
4592 /* Output the annotation. */
4593 tem
= Fcdr (Fcar (*annot
));
4596 if (0 > e_write (desc
, XSTRING (tem
)->data
, STRING_BYTES (XSTRING (tem
)),
4600 *annot
= Fcdr (*annot
);
4605 #ifndef WRITE_BUF_SIZE
4606 #define WRITE_BUF_SIZE (16 * 1024)
4609 /* Write NBYTES bytes starting at ADDR into descriptor DESC,
4610 encoding them with coding system CODING. */
4613 e_write (desc
, addr
, nbytes
, coding
)
4615 register char *addr
;
4616 register int nbytes
;
4617 struct coding_system
*coding
;
4619 char buf
[WRITE_BUF_SIZE
];
4621 /* We used to have a code for handling selective display here. But,
4622 now it is handled within encode_coding. */
4625 encode_coding (coding
, addr
, buf
, nbytes
, WRITE_BUF_SIZE
);
4626 nbytes
-= coding
->consumed
, addr
+= coding
->consumed
;
4627 if (coding
->produced
> 0)
4629 coding
->produced
-= write (desc
, buf
, coding
->produced
);
4630 if (coding
->produced
) return -1;
4638 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime
,
4639 Sverify_visited_file_modtime
, 1, 1, 0,
4640 "Return t if last mod time of BUF's visited file matches what BUF records.\n\
4641 This means that the file has not been changed since it was visited or saved.")
4647 Lisp_Object handler
;
4648 Lisp_Object filename
;
4650 CHECK_BUFFER (buf
, 0);
4653 if (!STRINGP (b
->filename
)) return Qt
;
4654 if (b
->modtime
== 0) return Qt
;
4656 /* If the file name has special constructs in it,
4657 call the corresponding file handler. */
4658 handler
= Ffind_file_name_handler (b
->filename
,
4659 Qverify_visited_file_modtime
);
4660 if (!NILP (handler
))
4661 return call2 (handler
, Qverify_visited_file_modtime
, buf
);
4663 filename
= ENCODE_FILE (b
->filename
);
4665 if (stat (XSTRING (filename
)->data
, &st
) < 0)
4667 /* If the file doesn't exist now and didn't exist before,
4668 we say that it isn't modified, provided the error is a tame one. */
4669 if (errno
== ENOENT
|| errno
== EACCES
|| errno
== ENOTDIR
)
4674 if (st
.st_mtime
== b
->modtime
4675 /* If both are positive, accept them if they are off by one second. */
4676 || (st
.st_mtime
> 0 && b
->modtime
> 0
4677 && (st
.st_mtime
== b
->modtime
+ 1
4678 || st
.st_mtime
== b
->modtime
- 1)))
4683 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime
,
4684 Sclear_visited_file_modtime
, 0, 0, 0,
4685 "Clear out records of last mod time of visited file.\n\
4686 Next attempt to save will certainly not complain of a discrepancy.")
4689 current_buffer
->modtime
= 0;
4693 DEFUN ("visited-file-modtime", Fvisited_file_modtime
,
4694 Svisited_file_modtime
, 0, 0, 0,
4695 "Return the current buffer's recorded visited file modification time.\n\
4696 The value is a list of the form (HIGH . LOW), like the time values\n\
4697 that `file-attributes' returns.")
4700 return long_to_cons ((unsigned long) current_buffer
->modtime
);
4703 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime
,
4704 Sset_visited_file_modtime
, 0, 1, 0,
4705 "Update buffer's recorded modification time from the visited file's time.\n\
4706 Useful if the buffer was not read from the file normally\n\
4707 or if the file itself has been changed for some known benign reason.\n\
4708 An argument specifies the modification time value to use\n\
4709 \(instead of that of the visited file), in the form of a list\n\
4710 \(HIGH . LOW) or (HIGH LOW).")
4712 Lisp_Object time_list
;
4714 if (!NILP (time_list
))
4715 current_buffer
->modtime
= cons_to_long (time_list
);
4718 register Lisp_Object filename
;
4720 Lisp_Object handler
;
4722 filename
= Fexpand_file_name (current_buffer
->filename
, Qnil
);
4724 /* If the file name has special constructs in it,
4725 call the corresponding file handler. */
4726 handler
= Ffind_file_name_handler (filename
, Qset_visited_file_modtime
);
4727 if (!NILP (handler
))
4728 /* The handler can find the file name the same way we did. */
4729 return call2 (handler
, Qset_visited_file_modtime
, Qnil
);
4731 filename
= ENCODE_FILE (filename
);
4733 if (stat (XSTRING (filename
)->data
, &st
) >= 0)
4734 current_buffer
->modtime
= st
.st_mtime
;
4744 message_with_string ("Autosaving...error for %s", current_buffer
->name
, 1);
4745 Fsleep_for (make_number (1), Qnil
);
4746 message_with_string ("Autosaving...error for %s", current_buffer
->name
, 0);
4747 Fsleep_for (make_number (1), Qnil
);
4748 message_with_string ("Autosaving...error for %s", current_buffer
->name
, 0);
4749 Fsleep_for (make_number (1), Qnil
);
4759 /* Get visited file's mode to become the auto save file's mode. */
4760 if (stat (XSTRING (current_buffer
->filename
)->data
, &st
) >= 0)
4761 /* But make sure we can overwrite it later! */
4762 auto_save_mode_bits
= st
.st_mode
| 0600;
4764 auto_save_mode_bits
= 0666;
4767 Fwrite_region (Qnil
, Qnil
,
4768 current_buffer
->auto_save_file_name
,
4769 Qnil
, Qlambda
, Qnil
, Qnil
);
4773 do_auto_save_unwind (stream
) /* used as unwind-protect function */
4778 fclose ((FILE *) (XFASTINT (XCONS (stream
)->car
) << 16
4779 | XFASTINT (XCONS (stream
)->cdr
)));
4784 do_auto_save_unwind_1 (value
) /* used as unwind-protect function */
4787 minibuffer_auto_raise
= XINT (value
);
4791 DEFUN ("do-auto-save", Fdo_auto_save
, Sdo_auto_save
, 0, 2, "",
4792 "Auto-save all buffers that need it.\n\
4793 This is all buffers that have auto-saving enabled\n\
4794 and are changed since last auto-saved.\n\
4795 Auto-saving writes the buffer into a file\n\
4796 so that your editing is not lost if the system crashes.\n\
4797 This file is not the file you visited; that changes only when you save.\n\
4798 Normally we run the normal hook `auto-save-hook' before saving.\n\n\
4799 A non-nil NO-MESSAGE argument means do not print any message if successful.\n\
4800 A non-nil CURRENT-ONLY argument means save only current buffer.")
4801 (no_message
, current_only
)
4802 Lisp_Object no_message
, current_only
;
4804 struct buffer
*old
= current_buffer
, *b
;
4805 Lisp_Object tail
, buf
;
4807 char *omessage
= echo_area_glyphs
;
4808 int omessage_length
= echo_area_glyphs_length
;
4809 int oldmultibyte
= message_enable_multibyte
;
4810 int do_handled_files
;
4813 Lisp_Object lispstream
;
4814 int count
= specpdl_ptr
- specpdl
;
4816 int orig_minibuffer_auto_raise
= minibuffer_auto_raise
;
4818 /* Ordinarily don't quit within this function,
4819 but don't make it impossible to quit (in case we get hung in I/O). */
4823 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
4824 point to non-strings reached from Vbuffer_alist. */
4829 if (!NILP (Vrun_hooks
))
4830 call1 (Vrun_hooks
, intern ("auto-save-hook"));
4832 if (STRINGP (Vauto_save_list_file_name
))
4834 Lisp_Object listfile
;
4835 listfile
= Fexpand_file_name (Vauto_save_list_file_name
, Qnil
);
4836 stream
= fopen (XSTRING (listfile
)->data
, "w");
4839 /* Arrange to close that file whether or not we get an error.
4840 Also reset auto_saving to 0. */
4841 lispstream
= Fcons (Qnil
, Qnil
);
4842 XSETFASTINT (XCONS (lispstream
)->car
, (EMACS_UINT
)stream
>> 16);
4843 XSETFASTINT (XCONS (lispstream
)->cdr
, (EMACS_UINT
)stream
& 0xffff);
4854 record_unwind_protect (do_auto_save_unwind
, lispstream
);
4855 record_unwind_protect (do_auto_save_unwind_1
,
4856 make_number (minibuffer_auto_raise
));
4857 minibuffer_auto_raise
= 0;
4860 /* First, save all files which don't have handlers. If Emacs is
4861 crashing, the handlers may tweak what is causing Emacs to crash
4862 in the first place, and it would be a shame if Emacs failed to
4863 autosave perfectly ordinary files because it couldn't handle some
4865 for (do_handled_files
= 0; do_handled_files
< 2; do_handled_files
++)
4866 for (tail
= Vbuffer_alist
; GC_CONSP (tail
); tail
= XCONS (tail
)->cdr
)
4868 buf
= XCONS (XCONS (tail
)->car
)->cdr
;
4871 /* Record all the buffers that have auto save mode
4872 in the special file that lists them. For each of these buffers,
4873 Record visited name (if any) and auto save name. */
4874 if (STRINGP (b
->auto_save_file_name
)
4875 && stream
!= NULL
&& do_handled_files
== 0)
4877 if (!NILP (b
->filename
))
4879 fwrite (XSTRING (b
->filename
)->data
, 1,
4880 STRING_BYTES (XSTRING (b
->filename
)), stream
);
4882 putc ('\n', stream
);
4883 fwrite (XSTRING (b
->auto_save_file_name
)->data
, 1,
4884 STRING_BYTES (XSTRING (b
->auto_save_file_name
)), stream
);
4885 putc ('\n', stream
);
4888 if (!NILP (current_only
)
4889 && b
!= current_buffer
)
4892 /* Don't auto-save indirect buffers.
4893 The base buffer takes care of it. */
4897 /* Check for auto save enabled
4898 and file changed since last auto save
4899 and file changed since last real save. */
4900 if (STRINGP (b
->auto_save_file_name
)
4901 && BUF_SAVE_MODIFF (b
) < BUF_MODIFF (b
)
4902 && b
->auto_save_modified
< BUF_MODIFF (b
)
4903 /* -1 means we've turned off autosaving for a while--see below. */
4904 && XINT (b
->save_length
) >= 0
4905 && (do_handled_files
4906 || NILP (Ffind_file_name_handler (b
->auto_save_file_name
,
4909 EMACS_TIME before_time
, after_time
;
4911 EMACS_GET_TIME (before_time
);
4913 /* If we had a failure, don't try again for 20 minutes. */
4914 if (b
->auto_save_failure_time
>= 0
4915 && EMACS_SECS (before_time
) - b
->auto_save_failure_time
< 1200)
4918 if ((XFASTINT (b
->save_length
) * 10
4919 > (BUF_Z (b
) - BUF_BEG (b
)) * 13)
4920 /* A short file is likely to change a large fraction;
4921 spare the user annoying messages. */
4922 && XFASTINT (b
->save_length
) > 5000
4923 /* These messages are frequent and annoying for `*mail*'. */
4924 && !EQ (b
->filename
, Qnil
)
4925 && NILP (no_message
))
4927 /* It has shrunk too much; turn off auto-saving here. */
4928 minibuffer_auto_raise
= orig_minibuffer_auto_raise
;
4929 message_with_string ("Buffer %s has shrunk a lot; auto save turned off there",
4931 minibuffer_auto_raise
= 0;
4932 /* Turn off auto-saving until there's a real save,
4933 and prevent any more warnings. */
4934 XSETINT (b
->save_length
, -1);
4935 Fsleep_for (make_number (1), Qnil
);
4938 set_buffer_internal (b
);
4939 if (!auto_saved
&& NILP (no_message
))
4940 message1 ("Auto-saving...");
4941 internal_condition_case (auto_save_1
, Qt
, auto_save_error
);
4943 b
->auto_save_modified
= BUF_MODIFF (b
);
4944 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4945 set_buffer_internal (old
);
4947 EMACS_GET_TIME (after_time
);
4949 /* If auto-save took more than 60 seconds,
4950 assume it was an NFS failure that got a timeout. */
4951 if (EMACS_SECS (after_time
) - EMACS_SECS (before_time
) > 60)
4952 b
->auto_save_failure_time
= EMACS_SECS (after_time
);
4956 /* Prevent another auto save till enough input events come in. */
4957 record_auto_save ();
4959 if (auto_saved
&& NILP (no_message
))
4963 sit_for (1, 0, 0, 0, 0);
4964 message2 (omessage
, omessage_length
, oldmultibyte
);
4967 message1 ("Auto-saving...done");
4972 unbind_to (count
, Qnil
);
4976 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved
,
4977 Sset_buffer_auto_saved
, 0, 0, 0,
4978 "Mark current buffer as auto-saved with its current text.\n\
4979 No auto-save file will be written until the buffer changes again.")
4982 current_buffer
->auto_save_modified
= MODIFF
;
4983 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4984 current_buffer
->auto_save_failure_time
= -1;
4988 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure
,
4989 Sclear_buffer_auto_save_failure
, 0, 0, 0,
4990 "Clear any record of a recent auto-save failure in the current buffer.")
4993 current_buffer
->auto_save_failure_time
= -1;
4997 DEFUN ("recent-auto-save-p", Frecent_auto_save_p
, Srecent_auto_save_p
,
4999 "Return t if buffer has been auto-saved since last read in or saved.")
5002 return (SAVE_MODIFF
< current_buffer
->auto_save_modified
) ? Qt
: Qnil
;
5005 /* Reading and completing file names */
5006 extern Lisp_Object
Ffile_name_completion (), Ffile_name_all_completions ();
5008 /* In the string VAL, change each $ to $$ and return the result. */
5011 double_dollars (val
)
5014 register unsigned char *old
, *new;
5018 osize
= STRING_BYTES (XSTRING (val
));
5020 /* Count the number of $ characters. */
5021 for (n
= osize
, count
= 0, old
= XSTRING (val
)->data
; n
> 0; n
--)
5022 if (*old
++ == '$') count
++;
5025 old
= XSTRING (val
)->data
;
5026 val
= make_uninit_multibyte_string (XSTRING (val
)->size
+ count
,
5028 new = XSTRING (val
)->data
;
5029 for (n
= osize
; n
> 0; n
--)
5042 DEFUN ("read-file-name-internal", Fread_file_name_internal
, Sread_file_name_internal
,
5044 "Internal subroutine for read-file-name. Do not call this.")
5045 (string
, dir
, action
)
5046 Lisp_Object string
, dir
, action
;
5047 /* action is nil for complete, t for return list of completions,
5048 lambda for verify final value */
5050 Lisp_Object name
, specdir
, realdir
, val
, orig_string
;
5052 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
5054 CHECK_STRING (string
, 0);
5061 /* No need to protect ACTION--we only compare it with t and nil. */
5062 GCPRO5 (string
, realdir
, name
, specdir
, orig_string
);
5064 if (XSTRING (string
)->size
== 0)
5066 if (EQ (action
, Qlambda
))
5074 orig_string
= string
;
5075 string
= Fsubstitute_in_file_name (string
);
5076 changed
= NILP (Fstring_equal (string
, orig_string
));
5077 name
= Ffile_name_nondirectory (string
);
5078 val
= Ffile_name_directory (string
);
5080 realdir
= Fexpand_file_name (val
, realdir
);
5085 specdir
= Ffile_name_directory (string
);
5086 val
= Ffile_name_completion (name
, realdir
);
5091 return double_dollars (string
);
5095 if (!NILP (specdir
))
5096 val
= concat2 (specdir
, val
);
5098 return double_dollars (val
);
5101 #endif /* not VMS */
5105 if (EQ (action
, Qt
))
5106 return Ffile_name_all_completions (name
, realdir
);
5107 /* Only other case actually used is ACTION = lambda */
5109 /* Supposedly this helps commands such as `cd' that read directory names,
5110 but can someone explain how it helps them? -- RMS */
5111 if (XSTRING (name
)->size
== 0)
5114 return Ffile_exists_p (string
);
5117 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
5118 "Read file name, prompting with PROMPT and completing in directory DIR.\n\
5119 Value is not expanded---you must call `expand-file-name' yourself.\n\
5120 Default name to DEFAULT-FILENAME if user enters a null string.\n\
5121 (If DEFAULT-FILENAME is omitted, the visited file name is used,\n\
5122 except that if INITIAL is specified, that combined with DIR is used.)\n\
5123 Fourth arg MUSTMATCH non-nil means require existing file's name.\n\
5124 Non-nil and non-t means also require confirmation after completion.\n\
5125 Fifth arg INITIAL specifies text to start with.\n\
5126 DIR defaults to current buffer's directory default.")
5127 (prompt
, dir
, default_filename
, mustmatch
, initial
)
5128 Lisp_Object prompt
, dir
, default_filename
, mustmatch
, initial
;
5130 Lisp_Object val
, insdef
, insdef1
, tem
;
5131 struct gcpro gcpro1
, gcpro2
;
5132 register char *homedir
;
5133 int replace_in_history
= 0;
5134 int add_to_history
= 0;
5138 dir
= current_buffer
->directory
;
5139 if (NILP (default_filename
))
5141 if (! NILP (initial
))
5142 default_filename
= Fexpand_file_name (initial
, dir
);
5144 default_filename
= current_buffer
->filename
;
5147 /* If dir starts with user's homedir, change that to ~. */
5148 homedir
= (char *) egetenv ("HOME");
5150 homedir
= strcpy (alloca (strlen (homedir
) + 1), homedir
);
5151 CORRECT_DIR_SEPS (homedir
);
5155 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
5156 && IS_DIRECTORY_SEP (XSTRING (dir
)->data
[strlen (homedir
)]))
5158 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
5159 STRING_BYTES (XSTRING (dir
)) - strlen (homedir
) + 1);
5160 XSTRING (dir
)->data
[0] = '~';
5163 if (insert_default_directory
&& STRINGP (dir
))
5166 if (!NILP (initial
))
5168 Lisp_Object args
[2], pos
;
5172 insdef
= Fconcat (2, args
);
5173 pos
= make_number (XSTRING (double_dollars (dir
))->size
);
5174 insdef1
= Fcons (double_dollars (insdef
), pos
);
5177 insdef1
= double_dollars (insdef
);
5179 else if (STRINGP (initial
))
5182 insdef1
= Fcons (double_dollars (insdef
), make_number (0));
5185 insdef
= Qnil
, insdef1
= Qnil
;
5188 count
= specpdl_ptr
- specpdl
;
5189 specbind (intern ("completion-ignore-case"), Qt
);
5192 GCPRO2 (insdef
, default_filename
);
5193 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
5194 dir
, mustmatch
, insdef1
,
5195 Qfile_name_history
, default_filename
, Qnil
);
5197 tem
= Fsymbol_value (Qfile_name_history
);
5198 if (CONSP (tem
) && EQ (XCONS (tem
)->car
, val
))
5199 replace_in_history
= 1;
5201 /* If Fcompleting_read returned the inserted default string itself
5202 (rather than a new string with the same contents),
5203 it has to mean that the user typed RET with the minibuffer empty.
5204 In that case, we really want to return ""
5205 so that commands such as set-visited-file-name can distinguish. */
5206 if (EQ (val
, default_filename
))
5208 /* In this case, Fcompleting_read has not added an element
5209 to the history. Maybe we should. */
5210 if (! replace_in_history
)
5213 val
= build_string ("");
5217 unbind_to (count
, Qnil
);
5222 error ("No file name specified");
5224 tem
= Fstring_equal (val
, insdef
);
5226 if (!NILP (tem
) && !NILP (default_filename
))
5227 val
= default_filename
;
5228 else if (XSTRING (val
)->size
== 0 && NILP (insdef
))
5230 if (!NILP (default_filename
))
5231 val
= default_filename
;
5233 error ("No default file name");
5235 val
= Fsubstitute_in_file_name (val
);
5237 if (replace_in_history
)
5238 /* Replace what Fcompleting_read added to the history
5239 with what we will actually return. */
5240 XCONS (Fsymbol_value (Qfile_name_history
))->car
= val
;
5241 else if (add_to_history
)
5243 /* Add the value to the history--but not if it matches
5244 the last value already there. */
5245 tem
= Fsymbol_value (Qfile_name_history
);
5246 if (! CONSP (tem
) || NILP (Fequal (XCONS (tem
)->car
, val
)))
5247 Fset (Qfile_name_history
,
5256 Qexpand_file_name
= intern ("expand-file-name");
5257 Qsubstitute_in_file_name
= intern ("substitute-in-file-name");
5258 Qdirectory_file_name
= intern ("directory-file-name");
5259 Qfile_name_directory
= intern ("file-name-directory");
5260 Qfile_name_nondirectory
= intern ("file-name-nondirectory");
5261 Qunhandled_file_name_directory
= intern ("unhandled-file-name-directory");
5262 Qfile_name_as_directory
= intern ("file-name-as-directory");
5263 Qcopy_file
= intern ("copy-file");
5264 Qmake_directory_internal
= intern ("make-directory-internal");
5265 Qdelete_directory
= intern ("delete-directory");
5266 Qdelete_file
= intern ("delete-file");
5267 Qrename_file
= intern ("rename-file");
5268 Qadd_name_to_file
= intern ("add-name-to-file");
5269 Qmake_symbolic_link
= intern ("make-symbolic-link");
5270 Qfile_exists_p
= intern ("file-exists-p");
5271 Qfile_executable_p
= intern ("file-executable-p");
5272 Qfile_readable_p
= intern ("file-readable-p");
5273 Qfile_writable_p
= intern ("file-writable-p");
5274 Qfile_symlink_p
= intern ("file-symlink-p");
5275 Qaccess_file
= intern ("access-file");
5276 Qfile_directory_p
= intern ("file-directory-p");
5277 Qfile_regular_p
= intern ("file-regular-p");
5278 Qfile_accessible_directory_p
= intern ("file-accessible-directory-p");
5279 Qfile_modes
= intern ("file-modes");
5280 Qset_file_modes
= intern ("set-file-modes");
5281 Qfile_newer_than_file_p
= intern ("file-newer-than-file-p");
5282 Qinsert_file_contents
= intern ("insert-file-contents");
5283 Qwrite_region
= intern ("write-region");
5284 Qverify_visited_file_modtime
= intern ("verify-visited-file-modtime");
5285 Qset_visited_file_modtime
= intern ("set-visited-file-modtime");
5287 staticpro (&Qexpand_file_name
);
5288 staticpro (&Qsubstitute_in_file_name
);
5289 staticpro (&Qdirectory_file_name
);
5290 staticpro (&Qfile_name_directory
);
5291 staticpro (&Qfile_name_nondirectory
);
5292 staticpro (&Qunhandled_file_name_directory
);
5293 staticpro (&Qfile_name_as_directory
);
5294 staticpro (&Qcopy_file
);
5295 staticpro (&Qmake_directory_internal
);
5296 staticpro (&Qdelete_directory
);
5297 staticpro (&Qdelete_file
);
5298 staticpro (&Qrename_file
);
5299 staticpro (&Qadd_name_to_file
);
5300 staticpro (&Qmake_symbolic_link
);
5301 staticpro (&Qfile_exists_p
);
5302 staticpro (&Qfile_executable_p
);
5303 staticpro (&Qfile_readable_p
);
5304 staticpro (&Qfile_writable_p
);
5305 staticpro (&Qaccess_file
);
5306 staticpro (&Qfile_symlink_p
);
5307 staticpro (&Qfile_directory_p
);
5308 staticpro (&Qfile_regular_p
);
5309 staticpro (&Qfile_accessible_directory_p
);
5310 staticpro (&Qfile_modes
);
5311 staticpro (&Qset_file_modes
);
5312 staticpro (&Qfile_newer_than_file_p
);
5313 staticpro (&Qinsert_file_contents
);
5314 staticpro (&Qwrite_region
);
5315 staticpro (&Qverify_visited_file_modtime
);
5316 staticpro (&Qset_visited_file_modtime
);
5318 Qfile_name_history
= intern ("file-name-history");
5319 Fset (Qfile_name_history
, Qnil
);
5320 staticpro (&Qfile_name_history
);
5322 Qfile_error
= intern ("file-error");
5323 staticpro (&Qfile_error
);
5324 Qfile_already_exists
= intern ("file-already-exists");
5325 staticpro (&Qfile_already_exists
);
5326 Qfile_date_error
= intern ("file-date-error");
5327 staticpro (&Qfile_date_error
);
5330 Qfind_buffer_file_type
= intern ("find-buffer-file-type");
5331 staticpro (&Qfind_buffer_file_type
);
5334 DEFVAR_LISP ("file-name-coding-system", &Vfile_name_coding_system
,
5335 "*Coding system for encoding file names.\n\
5336 If it is nil, default-file-name-coding-system (which see) is used.");
5337 Vfile_name_coding_system
= Qnil
;
5339 DEFVAR_LISP ("default-file-name-coding-system",
5340 &Vdefault_file_name_coding_system
,
5341 "Default coding system for encoding file names.\n\
5342 This variable is used only when file-name-coding-system is nil.\n\
5344 This variable is set/changed by the command set-language-environment.\n\
5345 User should not set this variable manually,\n\
5346 instead use file-name-coding-system to get a constant encoding\n\
5347 of file names regardless of the current language environment.");
5348 Vdefault_file_name_coding_system
= Qnil
;
5350 DEFVAR_LISP ("auto-save-file-format", &Vauto_save_file_format
,
5351 "*Format in which to write auto-save files.\n\
5352 Should be a list of symbols naming formats that are defined in `format-alist'.\n\
5353 If it is t, which is the default, auto-save files are written in the\n\
5354 same format as a regular save would use.");
5355 Vauto_save_file_format
= Qt
;
5357 Qformat_decode
= intern ("format-decode");
5358 staticpro (&Qformat_decode
);
5359 Qformat_annotate_function
= intern ("format-annotate-function");
5360 staticpro (&Qformat_annotate_function
);
5362 Qcar_less_than_car
= intern ("car-less-than-car");
5363 staticpro (&Qcar_less_than_car
);
5365 Fput (Qfile_error
, Qerror_conditions
,
5366 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
)));
5367 Fput (Qfile_error
, Qerror_message
,
5368 build_string ("File error"));
5370 Fput (Qfile_already_exists
, Qerror_conditions
,
5371 Fcons (Qfile_already_exists
,
5372 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
5373 Fput (Qfile_already_exists
, Qerror_message
,
5374 build_string ("File already exists"));
5376 Fput (Qfile_date_error
, Qerror_conditions
,
5377 Fcons (Qfile_date_error
,
5378 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
5379 Fput (Qfile_date_error
, Qerror_message
,
5380 build_string ("Cannot set file date"));
5382 DEFVAR_BOOL ("insert-default-directory", &insert_default_directory
,
5383 "*Non-nil means when reading a filename start with default dir in minibuffer.");
5384 insert_default_directory
= 1;
5386 DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm
,
5387 "*Non-nil means write new files with record format `stmlf'.\n\
5388 nil means use format `var'. This variable is meaningful only on VMS.");
5389 vms_stmlf_recfm
= 0;
5391 DEFVAR_LISP ("directory-sep-char", &Vdirectory_sep_char
,
5392 "Directory separator character for built-in functions that return file names.\n\
5393 The value should be either ?/ or ?\\ (any other value is treated as ?\\).\n\
5394 This variable affects the built-in functions only on Windows,\n\
5395 on other platforms, it is initialized so that Lisp code can find out\n\
5396 what the normal separator is.");
5397 XSETFASTINT (Vdirectory_sep_char
, '/');
5399 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist
,
5400 "*Alist of elements (REGEXP . HANDLER) for file names handled specially.\n\
5401 If a file name matches REGEXP, then all I/O on that file is done by calling\n\
5404 The first argument given to HANDLER is the name of the I/O primitive\n\
5405 to be handled; the remaining arguments are the arguments that were\n\
5406 passed to that primitive. For example, if you do\n\
5407 (file-exists-p FILENAME)\n\
5408 and FILENAME is handled by HANDLER, then HANDLER is called like this:\n\
5409 (funcall HANDLER 'file-exists-p FILENAME)\n\
5410 The function `find-file-name-handler' checks this list for a handler\n\
5411 for its argument.");
5412 Vfile_name_handler_alist
= Qnil
;
5414 DEFVAR_LISP ("set-auto-coding-function",
5415 &Vset_auto_coding_function
,
5416 "If non-nil, a function to call to decide a coding system of file.\n\
5417 One argument is passed to this function: the string of concatination\n\
5418 or the heading 1K-byte and the tailing 3K-byte of a file to be read.\n\
5419 This function should return a coding system to decode the file contents\n\
5420 specified in the heading lines with the format:\n\
5421 -*- ... coding: CODING-SYSTEM; ... -*-\n\
5422 or local variable spec of the tailing lines with `coding:' tag.");
5423 Vset_auto_coding_function
= Qnil
;
5425 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions
,
5426 "A list of functions to be called at the end of `insert-file-contents'.\n\
5427 Each is passed one argument, the number of bytes inserted. It should return\n\
5428 the new byte count, and leave point the same. If `insert-file-contents' is\n\
5429 intercepted by a handler from `file-name-handler-alist', that handler is\n\
5430 responsible for calling the after-insert-file-functions if appropriate.");
5431 Vafter_insert_file_functions
= Qnil
;
5433 DEFVAR_LISP ("write-region-annotate-functions", &Vwrite_region_annotate_functions
,
5434 "A list of functions to be called at the start of `write-region'.\n\
5435 Each is passed two arguments, START and END as for `write-region'.\n\
5436 These are usually two numbers but not always; see the documentation\n\
5437 for `write-region'. The function should return a list of pairs\n\
5438 of the form (POSITION . STRING), consisting of strings to be effectively\n\
5439 inserted at the specified positions of the file being written (1 means to\n\
5440 insert before the first byte written). The POSITIONs must be sorted into\n\
5441 increasing order. If there are several functions in the list, the several\n\
5442 lists are merged destructively.");
5443 Vwrite_region_annotate_functions
= Qnil
;
5445 DEFVAR_LISP ("write-region-annotations-so-far",
5446 &Vwrite_region_annotations_so_far
,
5447 "When an annotation function is called, this holds the previous annotations.\n\
5448 These are the annotations made by other annotation functions\n\
5449 that were already called. See also `write-region-annotate-functions'.");
5450 Vwrite_region_annotations_so_far
= Qnil
;
5452 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers
,
5453 "A list of file name handlers that temporarily should not be used.\n\
5454 This applies only to the operation `inhibit-file-name-operation'.");
5455 Vinhibit_file_name_handlers
= Qnil
;
5457 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation
,
5458 "The operation for which `inhibit-file-name-handlers' is applicable.");
5459 Vinhibit_file_name_operation
= Qnil
;
5461 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name
,
5462 "File name in which we write a list of all auto save file names.\n\
5463 This variable is initialized automatically from `auto-save-list-file-prefix'\n\
5464 shortly after Emacs reads your `.emacs' file, if you have not yet given it\n\
5466 Vauto_save_list_file_name
= Qnil
;
5468 defsubr (&Sfind_file_name_handler
);
5469 defsubr (&Sfile_name_directory
);
5470 defsubr (&Sfile_name_nondirectory
);
5471 defsubr (&Sunhandled_file_name_directory
);
5472 defsubr (&Sfile_name_as_directory
);
5473 defsubr (&Sdirectory_file_name
);
5474 defsubr (&Smake_temp_name
);
5475 defsubr (&Sexpand_file_name
);
5476 defsubr (&Ssubstitute_in_file_name
);
5477 defsubr (&Scopy_file
);
5478 defsubr (&Smake_directory_internal
);
5479 defsubr (&Sdelete_directory
);
5480 defsubr (&Sdelete_file
);
5481 defsubr (&Srename_file
);
5482 defsubr (&Sadd_name_to_file
);
5484 defsubr (&Smake_symbolic_link
);
5485 #endif /* S_IFLNK */
5487 defsubr (&Sdefine_logical_name
);
5490 defsubr (&Ssysnetunam
);
5491 #endif /* HPUX_NET */
5492 defsubr (&Sfile_name_absolute_p
);
5493 defsubr (&Sfile_exists_p
);
5494 defsubr (&Sfile_executable_p
);
5495 defsubr (&Sfile_readable_p
);
5496 defsubr (&Sfile_writable_p
);
5497 defsubr (&Saccess_file
);
5498 defsubr (&Sfile_symlink_p
);
5499 defsubr (&Sfile_directory_p
);
5500 defsubr (&Sfile_accessible_directory_p
);
5501 defsubr (&Sfile_regular_p
);
5502 defsubr (&Sfile_modes
);
5503 defsubr (&Sset_file_modes
);
5504 defsubr (&Sset_default_file_modes
);
5505 defsubr (&Sdefault_file_modes
);
5506 defsubr (&Sfile_newer_than_file_p
);
5507 defsubr (&Sinsert_file_contents
);
5508 defsubr (&Swrite_region
);
5509 defsubr (&Scar_less_than_car
);
5510 defsubr (&Sverify_visited_file_modtime
);
5511 defsubr (&Sclear_visited_file_modtime
);
5512 defsubr (&Svisited_file_modtime
);
5513 defsubr (&Sset_visited_file_modtime
);
5514 defsubr (&Sdo_auto_save
);
5515 defsubr (&Sset_buffer_auto_saved
);
5516 defsubr (&Sclear_buffer_auto_save_failure
);
5517 defsubr (&Srecent_auto_save_p
);
5519 defsubr (&Sread_file_name_internal
);
5520 defsubr (&Sread_file_name
);
5523 defsubr (&Sunix_sync
);