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)
55 #include <sys/param.h>
77 extern char *strerror ();
94 #include "intervals.h"
105 #endif /* not WINDOWSNT */
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;
493 /* Is it already a directory string? */
494 if (in
[size
] == ':' || in
[size
] == ']' || in
[size
] == '>')
496 /* Is it a VMS directory file name? If so, hack VMS syntax. */
497 else if (! index (in
, '/')
498 && ((size
> 3 && ! strcmp (&in
[size
- 3], ".DIR"))
499 || (size
> 3 && ! strcmp (&in
[size
- 3], ".dir"))
500 || (size
> 5 && (! strncmp (&in
[size
- 5], ".DIR", 4)
501 || ! strncmp (&in
[size
- 5], ".dir", 4))
502 && (in
[size
- 1] == '.' || in
[size
- 1] == ';')
503 && in
[size
] == '1')))
505 register char *p
, *dot
;
509 dir:x.dir --> dir:[x]
510 dir:[x]y.dir --> dir:[x.y] */
512 while (p
!= in
&& *p
!= ':' && *p
!= '>' && *p
!= ']') p
--;
515 strncpy (out
, in
, p
- in
);
534 dot
= index (p
, '.');
537 /* blindly remove any extension */
538 size
= strlen (out
) + (dot
- p
);
539 strncat (out
, p
, dot
- p
);
550 /* For Unix syntax, Append a slash if necessary */
551 if (!IS_DIRECTORY_SEP (out
[size
]))
553 out
[size
+ 1] = DIRECTORY_SEP
;
554 out
[size
+ 2] = '\0';
557 CORRECT_DIR_SEPS (out
);
563 DEFUN ("file-name-as-directory", Ffile_name_as_directory
,
564 Sfile_name_as_directory
, 1, 1, 0,
565 "Return a string representing file FILENAME interpreted as a directory.\n\
566 This operation exists because a directory is also a file, but its name as\n\
567 a directory is different from its name as a file.\n\
568 The result can be used as the value of `default-directory'\n\
569 or passed as second argument to `expand-file-name'.\n\
570 For a Unix-syntax file name, just appends a slash.\n\
571 On VMS, converts \"[X]FOO.DIR\" to \"[X.FOO]\", etc.")
578 CHECK_STRING (file
, 0);
582 /* If the file name has special constructs in it,
583 call the corresponding file handler. */
584 handler
= Ffind_file_name_handler (file
, Qfile_name_as_directory
);
586 return call2 (handler
, Qfile_name_as_directory
, file
);
588 buf
= (char *) alloca (STRING_BYTES (XSTRING (file
)) + 10);
589 return build_string (file_name_as_directory (buf
, XSTRING (file
)->data
));
593 * Convert from directory name to filename.
595 * xyzzy:[mukesh.emacs] => xyzzy:[mukesh]emacs.dir.1
596 * xyzzy:[mukesh] => xyzzy:[000000]mukesh.dir.1
597 * On UNIX, it's simple: just make sure there isn't a terminating /
599 * Value is nonzero if the string output is different from the input.
602 directory_file_name (src
, dst
)
610 struct FAB fab
= cc$rms_fab
;
611 struct NAM nam
= cc$rms_nam
;
612 char esa
[NAM$C_MAXRSS
];
617 if (! index (src
, '/')
618 && (src
[slen
- 1] == ']'
619 || src
[slen
- 1] == ':'
620 || src
[slen
- 1] == '>'))
622 /* VMS style - convert [x.y.z] to [x.y]z, [x] to [000000]x */
624 fab
.fab$b_fns
= slen
;
625 fab
.fab$l_nam
= &nam
;
626 fab
.fab$l_fop
= FAB$M_NAM
;
629 nam
.nam$b_ess
= sizeof esa
;
630 nam
.nam$b_nop
|= NAM$M_SYNCHK
;
632 /* We call SYS$PARSE to handle such things as [--] for us. */
633 if (SYS$
PARSE (&fab
, 0, 0) == RMS$_NORMAL
)
635 slen
= nam
.nam$b_esl
;
636 if (esa
[slen
- 1] == ';' && esa
[slen
- 2] == '.')
641 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
643 /* what about when we have logical_name:???? */
644 if (src
[slen
- 1] == ':')
645 { /* Xlate logical name and see what we get */
646 ptr
= strcpy (dst
, src
); /* upper case for getenv */
649 if ('a' <= *ptr
&& *ptr
<= 'z')
653 dst
[slen
- 1] = 0; /* remove colon */
654 if (!(src
= egetenv (dst
)))
656 /* should we jump to the beginning of this procedure?
657 Good points: allows us to use logical names that xlate
659 Bad points: can be a problem if we just translated to a device
661 For now, I'll punt and always expect VMS names, and hope for
664 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
665 { /* no recursion here! */
671 { /* not a directory spec */
676 bracket
= src
[slen
- 1];
678 /* If bracket is ']' or '>', bracket - 2 is the corresponding
680 ptr
= index (src
, bracket
- 2);
682 { /* no opening bracket */
686 if (!(rptr
= rindex (src
, '.')))
689 strncpy (dst
, src
, slen
);
693 dst
[slen
++] = bracket
;
698 /* If we have the top-level of a rooted directory (i.e. xx:[000000]),
699 then translate the device and recurse. */
700 if (dst
[slen
- 1] == ':'
701 && dst
[slen
- 2] != ':' /* skip decnet nodes */
702 && strcmp (src
+ slen
, "[000000]") == 0)
704 dst
[slen
- 1] = '\0';
705 if ((ptr
= egetenv (dst
))
706 && (rlen
= strlen (ptr
) - 1) > 0
707 && (ptr
[rlen
] == ']' || ptr
[rlen
] == '>')
708 && ptr
[rlen
- 1] == '.')
710 char * buf
= (char *) alloca (strlen (ptr
) + 1);
714 return directory_file_name (buf
, dst
);
719 strcat (dst
, "[000000]");
723 rlen
= strlen (rptr
) - 1;
724 strncat (dst
, rptr
, rlen
);
725 dst
[slen
+ rlen
] = '\0';
726 strcat (dst
, ".DIR.1");
730 /* Process as Unix format: just remove any final slash.
731 But leave "/" unchanged; do not change it to "". */
734 /* Handle // as root for apollo's. */
735 if ((slen
> 2 && dst
[slen
- 1] == '/')
736 || (slen
> 1 && dst
[0] != '/' && dst
[slen
- 1] == '/'))
740 && IS_DIRECTORY_SEP (dst
[slen
- 1])
742 && !IS_ANY_SEP (dst
[slen
- 2])
748 CORRECT_DIR_SEPS (dst
);
753 DEFUN ("directory-file-name", Fdirectory_file_name
, Sdirectory_file_name
,
755 "Returns the file name of the directory named DIRECTORY.\n\
756 This is the name of the file that holds the data for the directory DIRECTORY.\n\
757 This operation exists because a directory is also a file, but its name as\n\
758 a directory is different from its name as a file.\n\
759 In Unix-syntax, this function just removes the final slash.\n\
760 On VMS, given a VMS-syntax directory name such as \"[X.Y]\",\n\
761 it returns a file name such as \"[X]Y.DIR.1\".")
763 Lisp_Object directory
;
768 CHECK_STRING (directory
, 0);
770 if (NILP (directory
))
773 /* If the file name has special constructs in it,
774 call the corresponding file handler. */
775 handler
= Ffind_file_name_handler (directory
, Qdirectory_file_name
);
777 return call2 (handler
, Qdirectory_file_name
, directory
);
780 /* 20 extra chars is insufficient for VMS, since we might perform a
781 logical name translation. an equivalence string can be up to 255
782 chars long, so grab that much extra space... - sss */
783 buf
= (char *) alloca (STRING_BYTES (XSTRING (directory
)) + 20 + 255);
785 buf
= (char *) alloca (STRING_BYTES (XSTRING (directory
)) + 20);
787 directory_file_name (XSTRING (directory
)->data
, buf
);
788 return build_string (buf
);
791 DEFUN ("make-temp-name", Fmake_temp_name
, Smake_temp_name
, 1, 1, 0,
792 "Generate temporary file name (string) starting with PREFIX (a string).\n\
793 The Emacs process number forms part of the result,\n\
794 so there is no danger of generating a name being used by another process.\n\
795 In addition, this function makes an attempt to choose a name\n\
796 which has no existing file.")
802 /* Don't use too many characters of the restricted 8+3 DOS
804 val
= concat2 (prefix
, build_string ("a.XXX"));
806 val
= concat2 (prefix
, build_string ("XXXXXX"));
808 mktemp (XSTRING (val
)->data
);
810 CORRECT_DIR_SEPS (XSTRING (val
)->data
);
815 DEFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
816 "Convert filename NAME to absolute, and canonicalize it.\n\
817 Second arg DEFAULT-DIRECTORY is directory to start with if NAME is relative\n\
818 (does not start with slash); if DEFAULT-DIRECTORY is nil or missing,\n\
819 the current buffer's value of default-directory is used.\n\
820 File name components that are `.' are removed, and \n\
821 so are file name components followed by `..', along with the `..' itself;\n\
822 note that these simplifications are done without checking the resulting\n\
823 file names in the file system.\n\
824 An initial `~/' expands to your home directory.\n\
825 An initial `~USER/' expands to USER's home directory.\n\
826 See also the function `substitute-in-file-name'.")
827 (name
, default_directory
)
828 Lisp_Object name
, default_directory
;
832 register unsigned char *newdir
, *p
, *o
;
834 unsigned char *target
;
837 unsigned char * colon
= 0;
838 unsigned char * close
= 0;
839 unsigned char * slash
= 0;
840 unsigned char * brack
= 0;
841 int lbrack
= 0, rbrack
= 0;
846 int collapse_newdir
= 1;
851 CHECK_STRING (name
, 0);
853 /* If the file name has special constructs in it,
854 call the corresponding file handler. */
855 handler
= Ffind_file_name_handler (name
, Qexpand_file_name
);
857 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
859 /* Use the buffer's default-directory if DEFAULT_DIRECTORY is omitted. */
860 if (NILP (default_directory
))
861 default_directory
= current_buffer
->directory
;
862 if (! STRINGP (default_directory
))
863 default_directory
= build_string ("/");
865 if (!NILP (default_directory
))
867 handler
= Ffind_file_name_handler (default_directory
, Qexpand_file_name
);
869 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
872 o
= XSTRING (default_directory
)->data
;
874 /* Make sure DEFAULT_DIRECTORY is properly expanded.
875 It would be better to do this down below where we actually use
876 default_directory. Unfortunately, calling Fexpand_file_name recursively
877 could invoke GC, and the strings might be relocated. This would
878 be annoying because we have pointers into strings lying around
879 that would need adjusting, and people would add new pointers to
880 the code and forget to adjust them, resulting in intermittent bugs.
881 Putting this call here avoids all that crud.
883 The EQ test avoids infinite recursion. */
884 if (! NILP (default_directory
) && !EQ (default_directory
, name
)
885 /* Save time in some common cases - as long as default_directory
886 is not relative, it can be canonicalized with name below (if it
887 is needed at all) without requiring it to be expanded now. */
889 /* Detect MSDOS file names with drive specifiers. */
890 && ! (IS_DRIVE (o
[0]) && (IS_DEVICE_SEP (o
[1]) && IS_DIRECTORY_SEP (o
[2])))
892 /* Detect Windows file names in UNC format. */
893 && ! (IS_DIRECTORY_SEP (o
[0]) && IS_DIRECTORY_SEP (o
[1]))
895 #else /* not DOS_NT */
896 /* Detect Unix absolute file names (/... alone is not absolute on
898 && ! (IS_DIRECTORY_SEP (o
[0]))
899 #endif /* not DOS_NT */
905 default_directory
= Fexpand_file_name (default_directory
, Qnil
);
910 /* Filenames on VMS are always upper case. */
911 name
= Fupcase (name
);
913 #ifdef FILE_SYSTEM_CASE
914 name
= FILE_SYSTEM_CASE (name
);
917 nm
= XSTRING (name
)->data
;
920 /* We will force directory separators to be either all \ or /, so make
921 a local copy to modify, even if there ends up being no change. */
922 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
924 /* Find and remove drive specifier if present; this makes nm absolute
925 even if the rest of the name appears to be relative. */
927 unsigned char *colon
= rindex (nm
, ':');
930 /* Only recognize colon as part of drive specifier if there is a
931 single alphabetic character preceeding the colon (and if the
932 character before the drive letter, if present, is a directory
933 separator); this is to support the remote system syntax used by
934 ange-ftp, and the "po:username" syntax for POP mailboxes. */
938 else if (IS_DRIVE (colon
[-1])
939 && (colon
== nm
+ 1 || IS_DIRECTORY_SEP (colon
[-2])))
946 while (--colon
>= nm
)
953 /* If we see "c://somedir", we want to strip the first slash after the
954 colon when stripping the drive letter. Otherwise, this expands to
956 if (drive
&& IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
958 #endif /* WINDOWSNT */
962 /* Discard any previous drive specifier if nm is now in UNC format. */
963 if (IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
969 /* If nm is absolute, look for /./ or /../ sequences; if none are
970 found, we can probably return right away. We will avoid allocating
971 a new string if name is already fully expanded. */
973 IS_DIRECTORY_SEP (nm
[0])
978 && (drive
|| IS_DIRECTORY_SEP (nm
[1]))
985 /* If it turns out that the filename we want to return is just a
986 suffix of FILENAME, we don't need to go through and edit
987 things; we just need to construct a new string using data
988 starting at the middle of FILENAME. If we set lose to a
989 non-zero value, that means we've discovered that we can't do
996 /* Since we know the name is absolute, we can assume that each
997 element starts with a "/". */
999 /* "." and ".." are hairy. */
1000 if (IS_DIRECTORY_SEP (p
[0])
1002 && (IS_DIRECTORY_SEP (p
[2])
1004 || (p
[2] == '.' && (IS_DIRECTORY_SEP (p
[3])
1011 /* if dev:[dir]/, move nm to / */
1012 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1013 nm
= (brack
? brack
+ 1 : colon
+ 1);
1014 lbrack
= rbrack
= 0;
1022 /* VMS pre V4.4,convert '-'s in filenames. */
1023 if (lbrack
== rbrack
)
1025 if (dots
< 2) /* this is to allow negative version numbers */
1030 if (lbrack
> rbrack
&&
1031 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1032 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1038 /* count open brackets, reset close bracket pointer */
1039 if (p
[0] == '[' || p
[0] == '<')
1040 lbrack
++, brack
= 0;
1041 /* count close brackets, set close bracket pointer */
1042 if (p
[0] == ']' || p
[0] == '>')
1043 rbrack
++, brack
= p
;
1044 /* detect ][ or >< */
1045 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1047 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1048 nm
= p
+ 1, lose
= 1;
1049 if (p
[0] == ':' && (colon
|| slash
))
1050 /* if dev1:[dir]dev2:, move nm to dev2: */
1056 /* if /name/dev:, move nm to dev: */
1059 /* if node::dev:, move colon following dev */
1060 else if (colon
&& colon
[-1] == ':')
1062 /* if dev1:dev2:, move nm to dev2: */
1063 else if (colon
&& colon
[-1] != ':')
1068 if (p
[0] == ':' && !colon
)
1074 if (lbrack
== rbrack
)
1077 else if (p
[0] == '.')
1085 if (index (nm
, '/'))
1086 return build_string (sys_translate_unix (nm
));
1089 /* Make sure directories are all separated with / or \ as
1090 desired, but avoid allocation of a new string when not
1092 CORRECT_DIR_SEPS (nm
);
1094 if (IS_DIRECTORY_SEP (nm
[1]))
1096 if (strcmp (nm
, XSTRING (name
)->data
) != 0)
1097 name
= build_string (nm
);
1101 /* drive must be set, so this is okay */
1102 if (strcmp (nm
- 2, XSTRING (name
)->data
) != 0)
1104 name
= make_string (nm
- 2, p
- nm
+ 2);
1105 XSTRING (name
)->data
[0] = DRIVE_LETTER (drive
);
1106 XSTRING (name
)->data
[1] = ':';
1109 #else /* not DOS_NT */
1110 if (nm
== XSTRING (name
)->data
)
1112 return build_string (nm
);
1113 #endif /* not DOS_NT */
1117 /* At this point, nm might or might not be an absolute file name. We
1118 need to expand ~ or ~user if present, otherwise prefix nm with
1119 default_directory if nm is not absolute, and finally collapse /./
1120 and /foo/../ sequences.
1122 We set newdir to be the appropriate prefix if one is needed:
1123 - the relevant user directory if nm starts with ~ or ~user
1124 - the specified drive's working dir (DOS/NT only) if nm does not
1126 - the value of default_directory.
1128 Note that these prefixes are not guaranteed to be absolute (except
1129 for the working dir of a drive). Therefore, to ensure we always
1130 return an absolute name, if the final prefix is not absolute we
1131 append it to the current working directory. */
1135 if (nm
[0] == '~') /* prefix ~ */
1137 if (IS_DIRECTORY_SEP (nm
[1])
1141 || nm
[1] == 0) /* ~ by itself */
1143 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1144 newdir
= (unsigned char *) "";
1147 collapse_newdir
= 0;
1150 nm
++; /* Don't leave the slash in nm. */
1153 else /* ~user/filename */
1155 for (p
= nm
; *p
&& (!IS_DIRECTORY_SEP (*p
)
1160 o
= (unsigned char *) alloca (p
- nm
+ 1);
1161 bcopy ((char *) nm
, o
, p
- nm
);
1164 pw
= (struct passwd
*) getpwnam (o
+ 1);
1167 newdir
= (unsigned char *) pw
-> pw_dir
;
1169 nm
= p
+ 1; /* skip the terminator */
1173 collapse_newdir
= 0;
1178 /* If we don't find a user of that name, leave the name
1179 unchanged; don't move nm forward to p. */
1184 /* On DOS and Windows, nm is absolute if a drive name was specified;
1185 use the drive's current directory as the prefix if needed. */
1186 if (!newdir
&& drive
)
1188 /* Get default directory if needed to make nm absolute. */
1189 if (!IS_DIRECTORY_SEP (nm
[0]))
1191 newdir
= alloca (MAXPATHLEN
+ 1);
1192 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1197 /* Either nm starts with /, or drive isn't mounted. */
1198 newdir
= alloca (4);
1199 newdir
[0] = DRIVE_LETTER (drive
);
1207 /* Finally, if no prefix has been specified and nm is not absolute,
1208 then it must be expanded relative to default_directory. */
1212 /* /... alone is not absolute on DOS and Windows. */
1213 && !IS_DIRECTORY_SEP (nm
[0])
1216 && !(IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1223 newdir
= XSTRING (default_directory
)->data
;
1229 /* First ensure newdir is an absolute name. */
1231 /* Detect MSDOS file names with drive specifiers. */
1232 ! (IS_DRIVE (newdir
[0])
1233 && IS_DEVICE_SEP (newdir
[1]) && IS_DIRECTORY_SEP (newdir
[2]))
1235 /* Detect Windows file names in UNC format. */
1236 && ! (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1240 /* Effectively, let newdir be (expand-file-name newdir cwd).
1241 Because of the admonition against calling expand-file-name
1242 when we have pointers into lisp strings, we accomplish this
1243 indirectly by prepending newdir to nm if necessary, and using
1244 cwd (or the wd of newdir's drive) as the new newdir. */
1246 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1251 if (!IS_DIRECTORY_SEP (nm
[0]))
1253 char * tmp
= alloca (strlen (newdir
) + strlen (nm
) + 2);
1254 file_name_as_directory (tmp
, newdir
);
1258 newdir
= alloca (MAXPATHLEN
+ 1);
1261 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1268 /* Strip off drive name from prefix, if present. */
1269 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1275 /* Keep only a prefix from newdir if nm starts with slash
1276 (//server/share for UNC, nothing otherwise). */
1277 if (IS_DIRECTORY_SEP (nm
[0]) && collapse_newdir
)
1280 if (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1282 newdir
= strcpy (alloca (strlen (newdir
) + 1), newdir
);
1284 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1286 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1298 /* Get rid of any slash at the end of newdir, unless newdir is
1299 just // (an incomplete UNC name). */
1300 length
= strlen (newdir
);
1301 if (length
> 0 && IS_DIRECTORY_SEP (newdir
[length
- 1])
1303 && !(length
== 2 && IS_DIRECTORY_SEP (newdir
[0]))
1307 unsigned char *temp
= (unsigned char *) alloca (length
);
1308 bcopy (newdir
, temp
, length
- 1);
1309 temp
[length
- 1] = 0;
1317 /* Now concatenate the directory and name to new space in the stack frame */
1318 tlen
+= strlen (nm
) + 1;
1320 /* Add reserved space for drive name. (The Microsoft x86 compiler
1321 produces incorrect code if the following two lines are combined.) */
1322 target
= (unsigned char *) alloca (tlen
+ 2);
1324 #else /* not DOS_NT */
1325 target
= (unsigned char *) alloca (tlen
);
1326 #endif /* not DOS_NT */
1332 if (nm
[0] == 0 || IS_DIRECTORY_SEP (nm
[0]))
1333 strcpy (target
, newdir
);
1336 file_name_as_directory (target
, newdir
);
1339 strcat (target
, nm
);
1341 if (index (target
, '/'))
1342 strcpy (target
, sys_translate_unix (target
));
1345 /* ASSERT (IS_DIRECTORY_SEP (target[0])) if not VMS */
1347 /* Now canonicalize by removing /. and /foo/.. if they appear. */
1355 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1361 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1362 /* brackets are offset from each other by 2 */
1365 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1366 /* convert [foo][bar] to [bar] */
1367 while (o
[-1] != '[' && o
[-1] != '<')
1369 else if (*p
== '-' && *o
!= '.')
1372 else if (p
[0] == '-' && o
[-1] == '.' &&
1373 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1374 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1378 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1379 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1381 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1383 /* else [foo.-] ==> [-] */
1389 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1390 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1396 if (!IS_DIRECTORY_SEP (*p
))
1400 else if (IS_DIRECTORY_SEP (p
[0])
1402 && (IS_DIRECTORY_SEP (p
[2])
1405 /* If "/." is the entire filename, keep the "/". Otherwise,
1406 just delete the whole "/.". */
1407 if (o
== target
&& p
[2] == '\0')
1411 else if (IS_DIRECTORY_SEP (p
[0]) && p
[1] == '.' && p
[2] == '.'
1412 /* `/../' is the "superroot" on certain file systems. */
1414 && (IS_DIRECTORY_SEP (p
[3]) || p
[3] == 0))
1416 while (o
!= target
&& (--o
) && !IS_DIRECTORY_SEP (*o
))
1418 /* Keep initial / only if this is the whole name. */
1419 if (o
== target
&& IS_ANY_SEP (*o
) && p
[3] == 0)
1427 #endif /* not VMS */
1431 /* At last, set drive name. */
1433 /* Except for network file name. */
1434 if (!(IS_DIRECTORY_SEP (target
[0]) && IS_DIRECTORY_SEP (target
[1])))
1435 #endif /* WINDOWSNT */
1437 if (!drive
) abort ();
1439 target
[0] = DRIVE_LETTER (drive
);
1442 CORRECT_DIR_SEPS (target
);
1445 return make_string (target
, o
- target
);
1449 /* Changed this DEFUN to a DEAFUN, so as not to confuse `make-docfile'. */
1450 DEAFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
1451 "Convert FILENAME to absolute, and canonicalize it.\n\
1452 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
1453 (does not start with slash); if DEFAULT is nil or missing,\n\
1454 the current buffer's value of default-directory is used.\n\
1455 Filenames containing `.' or `..' as components are simplified;\n\
1456 initial `~/' expands to your home directory.\n\
1457 See also the function `substitute-in-file-name'.")
1459 Lisp_Object name
, defalt
;
1463 register unsigned char *newdir
, *p
, *o
;
1465 unsigned char *target
;
1469 unsigned char * colon
= 0;
1470 unsigned char * close
= 0;
1471 unsigned char * slash
= 0;
1472 unsigned char * brack
= 0;
1473 int lbrack
= 0, rbrack
= 0;
1477 CHECK_STRING (name
, 0);
1480 /* Filenames on VMS are always upper case. */
1481 name
= Fupcase (name
);
1484 nm
= XSTRING (name
)->data
;
1486 /* If nm is absolute, flush ...// and detect /./ and /../.
1487 If no /./ or /../ we can return right away. */
1499 if (p
[0] == '/' && p
[1] == '/'
1501 /* // at start of filename is meaningful on Apollo system. */
1506 if (p
[0] == '/' && p
[1] == '~')
1507 nm
= p
+ 1, lose
= 1;
1508 if (p
[0] == '/' && p
[1] == '.'
1509 && (p
[2] == '/' || p
[2] == 0
1510 || (p
[2] == '.' && (p
[3] == '/' || p
[3] == 0))))
1516 /* if dev:[dir]/, move nm to / */
1517 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1518 nm
= (brack
? brack
+ 1 : colon
+ 1);
1519 lbrack
= rbrack
= 0;
1527 /* VMS pre V4.4,convert '-'s in filenames. */
1528 if (lbrack
== rbrack
)
1530 if (dots
< 2) /* this is to allow negative version numbers */
1535 if (lbrack
> rbrack
&&
1536 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1537 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1543 /* count open brackets, reset close bracket pointer */
1544 if (p
[0] == '[' || p
[0] == '<')
1545 lbrack
++, brack
= 0;
1546 /* count close brackets, set close bracket pointer */
1547 if (p
[0] == ']' || p
[0] == '>')
1548 rbrack
++, brack
= p
;
1549 /* detect ][ or >< */
1550 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1552 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1553 nm
= p
+ 1, lose
= 1;
1554 if (p
[0] == ':' && (colon
|| slash
))
1555 /* if dev1:[dir]dev2:, move nm to dev2: */
1561 /* If /name/dev:, move nm to dev: */
1564 /* If node::dev:, move colon following dev */
1565 else if (colon
&& colon
[-1] == ':')
1567 /* If dev1:dev2:, move nm to dev2: */
1568 else if (colon
&& colon
[-1] != ':')
1573 if (p
[0] == ':' && !colon
)
1579 if (lbrack
== rbrack
)
1582 else if (p
[0] == '.')
1590 if (index (nm
, '/'))
1591 return build_string (sys_translate_unix (nm
));
1593 if (nm
== XSTRING (name
)->data
)
1595 return build_string (nm
);
1599 /* Now determine directory to start with and put it in NEWDIR */
1603 if (nm
[0] == '~') /* prefix ~ */
1608 || nm
[1] == 0)/* ~/filename */
1610 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1611 newdir
= (unsigned char *) "";
1614 nm
++; /* Don't leave the slash in nm. */
1617 else /* ~user/filename */
1619 /* Get past ~ to user */
1620 unsigned char *user
= nm
+ 1;
1621 /* Find end of name. */
1622 unsigned char *ptr
= (unsigned char *) index (user
, '/');
1623 int len
= ptr
? ptr
- user
: strlen (user
);
1625 unsigned char *ptr1
= index (user
, ':');
1626 if (ptr1
!= 0 && ptr1
- user
< len
)
1629 /* Copy the user name into temp storage. */
1630 o
= (unsigned char *) alloca (len
+ 1);
1631 bcopy ((char *) user
, o
, len
);
1634 /* Look up the user name. */
1635 pw
= (struct passwd
*) getpwnam (o
+ 1);
1637 error ("\"%s\" isn't a registered user", o
+ 1);
1639 newdir
= (unsigned char *) pw
->pw_dir
;
1641 /* Discard the user name from NM. */
1648 #endif /* not VMS */
1652 defalt
= current_buffer
->directory
;
1653 CHECK_STRING (defalt
, 1);
1654 newdir
= XSTRING (defalt
)->data
;
1657 /* Now concatenate the directory and name to new space in the stack frame */
1659 tlen
= (newdir
? strlen (newdir
) + 1 : 0) + strlen (nm
) + 1;
1660 target
= (unsigned char *) alloca (tlen
);
1666 if (nm
[0] == 0 || nm
[0] == '/')
1667 strcpy (target
, newdir
);
1670 file_name_as_directory (target
, newdir
);
1673 strcat (target
, nm
);
1675 if (index (target
, '/'))
1676 strcpy (target
, sys_translate_unix (target
));
1679 /* Now canonicalize by removing /. and /foo/.. if they appear */
1687 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1693 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1694 /* brackets are offset from each other by 2 */
1697 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1698 /* convert [foo][bar] to [bar] */
1699 while (o
[-1] != '[' && o
[-1] != '<')
1701 else if (*p
== '-' && *o
!= '.')
1704 else if (p
[0] == '-' && o
[-1] == '.' &&
1705 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1706 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1710 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1711 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1713 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1715 /* else [foo.-] ==> [-] */
1721 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1722 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1732 else if (!strncmp (p
, "//", 2)
1734 /* // at start of filename is meaningful in Apollo system. */
1742 else if (p
[0] == '/' && p
[1] == '.' &&
1743 (p
[2] == '/' || p
[2] == 0))
1745 else if (!strncmp (p
, "/..", 3)
1746 /* `/../' is the "superroot" on certain file systems. */
1748 && (p
[3] == '/' || p
[3] == 0))
1750 while (o
!= target
&& *--o
!= '/')
1753 if (o
== target
+ 1 && o
[-1] == '/' && o
[0] == '/')
1757 if (o
== target
&& *o
== '/')
1765 #endif /* not VMS */
1768 return make_string (target
, o
- target
);
1772 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name
,
1773 Ssubstitute_in_file_name
, 1, 1, 0,
1774 "Substitute environment variables referred to in FILENAME.\n\
1775 `$FOO' where FOO is an environment variable name means to substitute\n\
1776 the value of that variable. The variable name should be terminated\n\
1777 with a character not a letter, digit or underscore; otherwise, enclose\n\
1778 the entire variable name in braces.\n\
1779 If `/~' appears, all of FILENAME through that `/' is discarded.\n\n\
1780 On VMS, `$' substitution is not done; this function does little and only\n\
1781 duplicates what `expand-file-name' does.")
1783 Lisp_Object filename
;
1787 register unsigned char *s
, *p
, *o
, *x
, *endp
;
1788 unsigned char *target
;
1790 int substituted
= 0;
1792 Lisp_Object handler
;
1794 CHECK_STRING (filename
, 0);
1796 /* If the file name has special constructs in it,
1797 call the corresponding file handler. */
1798 handler
= Ffind_file_name_handler (filename
, Qsubstitute_in_file_name
);
1799 if (!NILP (handler
))
1800 return call2 (handler
, Qsubstitute_in_file_name
, filename
);
1802 nm
= XSTRING (filename
)->data
;
1804 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
1805 CORRECT_DIR_SEPS (nm
);
1806 substituted
= (strcmp (nm
, XSTRING (filename
)->data
) != 0);
1808 endp
= nm
+ STRING_BYTES (XSTRING (filename
));
1810 /* If /~ or // appears, discard everything through first slash. */
1812 for (p
= nm
; p
!= endp
; p
++)
1815 #if defined (APOLLO) || defined (WINDOWSNT)
1816 /* // at start of file name is meaningful in Apollo and
1817 WindowsNT systems. */
1818 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != nm
)
1819 #else /* not (APOLLO || WINDOWSNT) */
1820 || IS_DIRECTORY_SEP (p
[0])
1821 #endif /* not (APOLLO || WINDOWSNT) */
1826 || p
[-1] == ':' || p
[-1] == ']' || p
[-1] == '>'
1828 || IS_DIRECTORY_SEP (p
[-1])))
1834 /* see comment in expand-file-name about drive specifiers */
1835 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
1836 && p
> nm
&& IS_DIRECTORY_SEP (p
[-1]))
1845 return build_string (nm
);
1848 /* See if any variables are substituted into the string
1849 and find the total length of their values in `total' */
1851 for (p
= nm
; p
!= endp
;)
1861 /* "$$" means a single "$" */
1870 while (p
!= endp
&& *p
!= '}') p
++;
1871 if (*p
!= '}') goto missingclose
;
1877 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1881 /* Copy out the variable name */
1882 target
= (unsigned char *) alloca (s
- o
+ 1);
1883 strncpy (target
, o
, s
- o
);
1886 strupr (target
); /* $home == $HOME etc. */
1889 /* Get variable value */
1890 o
= (unsigned char *) egetenv (target
);
1891 if (!o
) goto badvar
;
1892 total
+= strlen (o
);
1899 /* If substitution required, recopy the string and do it */
1900 /* Make space in stack frame for the new copy */
1901 xnm
= (unsigned char *) alloca (STRING_BYTES (XSTRING (filename
)) + total
+ 1);
1904 /* Copy the rest of the name through, replacing $ constructs with values */
1921 while (p
!= endp
&& *p
!= '}') p
++;
1922 if (*p
!= '}') goto missingclose
;
1928 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1932 /* Copy out the variable name */
1933 target
= (unsigned char *) alloca (s
- o
+ 1);
1934 strncpy (target
, o
, s
- o
);
1937 strupr (target
); /* $home == $HOME etc. */
1940 /* Get variable value */
1941 o
= (unsigned char *) egetenv (target
);
1945 if (STRING_MULTIBYTE (filename
))
1947 /* If the original string is multibyte,
1948 convert what we substitute into multibyte. */
1949 unsigned char workbuf
[4], *str
;
1955 c
= unibyte_char_to_multibyte (c
);
1956 if (! SINGLE_BYTE_CHAR_P (c
))
1958 len
= CHAR_STRING (c
, workbuf
, str
);
1959 bcopy (str
, x
, len
);
1975 /* If /~ or // appears, discard everything through first slash. */
1977 for (p
= xnm
; p
!= x
; p
++)
1979 #if defined (APOLLO) || defined (WINDOWSNT)
1980 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != xnm
)
1981 #else /* not (APOLLO || WINDOWSNT) */
1982 || IS_DIRECTORY_SEP (p
[0])
1983 #endif /* not (APOLLO || WINDOWSNT) */
1985 && p
!= xnm
&& IS_DIRECTORY_SEP (p
[-1]))
1988 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
1989 && p
> nm
&& IS_DIRECTORY_SEP (p
[-1]))
1993 if (STRING_MULTIBYTE (filename
))
1994 return make_string (xnm
, x
- xnm
);
1995 return make_unibyte_string (xnm
, x
- xnm
);
1998 error ("Bad format environment-variable substitution");
2000 error ("Missing \"}\" in environment-variable substitution");
2002 error ("Substituting nonexistent environment variable \"%s\"", target
);
2005 #endif /* not VMS */
2008 /* A slightly faster and more convenient way to get
2009 (directory-file-name (expand-file-name FOO)). */
2012 expand_and_dir_to_file (filename
, defdir
)
2013 Lisp_Object filename
, defdir
;
2015 register Lisp_Object absname
;
2017 absname
= Fexpand_file_name (filename
, defdir
);
2020 register int c
= XSTRING (absname
)->data
[STRING_BYTES (XSTRING (absname
)) - 1];
2021 if (c
== ':' || c
== ']' || c
== '>')
2022 absname
= Fdirectory_file_name (absname
);
2025 /* Remove final slash, if any (unless this is the root dir).
2026 stat behaves differently depending! */
2027 if (XSTRING (absname
)->size
> 1
2028 && IS_DIRECTORY_SEP (XSTRING (absname
)->data
[STRING_BYTES (XSTRING (absname
)) - 1])
2029 && !IS_DEVICE_SEP (XSTRING (absname
)->data
[STRING_BYTES (XSTRING (absname
))-2]))
2030 /* We cannot take shortcuts; they might be wrong for magic file names. */
2031 absname
= Fdirectory_file_name (absname
);
2036 /* Signal an error if the file ABSNAME already exists.
2037 If INTERACTIVE is nonzero, ask the user whether to proceed,
2038 and bypass the error if the user says to go ahead.
2039 QUERYSTRING is a name for the action that is being considered
2042 *STATPTR is used to store the stat information if the file exists.
2043 If the file does not exist, STATPTR->st_mode is set to 0.
2044 If STATPTR is null, we don't store into it.
2046 If QUICK is nonzero, we ask for y or n, not yes or no. */
2049 barf_or_query_if_file_exists (absname
, querystring
, interactive
, statptr
, quick
)
2050 Lisp_Object absname
;
2051 unsigned char *querystring
;
2053 struct stat
*statptr
;
2056 register Lisp_Object tem
;
2057 struct stat statbuf
;
2058 struct gcpro gcpro1
;
2060 /* stat is a good way to tell whether the file exists,
2061 regardless of what access permissions it has. */
2062 if (stat (XSTRING (absname
)->data
, &statbuf
) >= 0)
2065 Fsignal (Qfile_already_exists
,
2066 Fcons (build_string ("File already exists"),
2067 Fcons (absname
, Qnil
)));
2069 tem
= format1 ("File %s already exists; %s anyway? ",
2070 XSTRING (absname
)->data
, querystring
);
2072 tem
= Fy_or_n_p (tem
);
2074 tem
= do_yes_or_no_p (tem
);
2077 Fsignal (Qfile_already_exists
,
2078 Fcons (build_string ("File already exists"),
2079 Fcons (absname
, Qnil
)));
2086 statptr
->st_mode
= 0;
2091 DEFUN ("copy-file", Fcopy_file
, Scopy_file
, 2, 4,
2092 "fCopy file: \nFCopy %s to file: \np\nP",
2093 "Copy FILE to NEWNAME. Both args must be strings.\n\
2094 Signals a `file-already-exists' error if file NEWNAME already exists,\n\
2095 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.\n\
2096 A number as third arg means request confirmation if NEWNAME already exists.\n\
2097 This is what happens in interactive use with M-x.\n\
2098 Fourth arg KEEP-TIME non-nil means give the new file the same\n\
2099 last-modified time as the old one. (This works on only some systems.)\n\
2100 A prefix arg makes KEEP-TIME non-nil.")
2101 (file
, newname
, ok_if_already_exists
, keep_date
)
2102 Lisp_Object file
, newname
, ok_if_already_exists
, keep_date
;
2105 char buf
[16 * 1024];
2106 struct stat st
, out_st
;
2107 Lisp_Object handler
;
2108 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2109 int count
= specpdl_ptr
- specpdl
;
2110 int input_file_statable_p
;
2111 Lisp_Object encoded_file
, encoded_newname
;
2113 encoded_file
= encoded_newname
= Qnil
;
2114 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2115 CHECK_STRING (file
, 0);
2116 CHECK_STRING (newname
, 1);
2118 file
= Fexpand_file_name (file
, Qnil
);
2119 newname
= Fexpand_file_name (newname
, Qnil
);
2121 /* If the input file name has special constructs in it,
2122 call the corresponding file handler. */
2123 handler
= Ffind_file_name_handler (file
, Qcopy_file
);
2124 /* Likewise for output file name. */
2126 handler
= Ffind_file_name_handler (newname
, Qcopy_file
);
2127 if (!NILP (handler
))
2128 RETURN_UNGCPRO (call5 (handler
, Qcopy_file
, file
, newname
,
2129 ok_if_already_exists
, keep_date
));
2131 encoded_file
= ENCODE_FILE (file
);
2132 encoded_newname
= ENCODE_FILE (newname
);
2134 if (NILP (ok_if_already_exists
)
2135 || INTEGERP (ok_if_already_exists
))
2136 barf_or_query_if_file_exists (encoded_newname
, "copy to it",
2137 INTEGERP (ok_if_already_exists
), &out_st
, 0);
2138 else if (stat (XSTRING (encoded_newname
)->data
, &out_st
) < 0)
2141 ifd
= open (XSTRING (encoded_file
)->data
, O_RDONLY
);
2143 report_file_error ("Opening input file", Fcons (file
, Qnil
));
2145 record_unwind_protect (close_file_unwind
, make_number (ifd
));
2147 /* We can only copy regular files and symbolic links. Other files are not
2149 input_file_statable_p
= (fstat (ifd
, &st
) >= 0);
2151 #if !defined (MSDOS) || __DJGPP__ > 1
2152 if (out_st
.st_mode
!= 0
2153 && st
.st_dev
== out_st
.st_dev
&& st
.st_ino
== out_st
.st_ino
)
2156 report_file_error ("Input and output files are the same",
2157 Fcons (file
, Fcons (newname
, Qnil
)));
2161 #if defined (S_ISREG) && defined (S_ISLNK)
2162 if (input_file_statable_p
)
2164 if (!(S_ISREG (st
.st_mode
)) && !(S_ISLNK (st
.st_mode
)))
2166 #if defined (EISDIR)
2167 /* Get a better looking error message. */
2170 report_file_error ("Non-regular file", Fcons (file
, Qnil
));
2173 #endif /* S_ISREG && S_ISLNK */
2176 /* Create the copy file with the same record format as the input file */
2177 ofd
= sys_creat (XSTRING (encoded_newname
)->data
, 0666, ifd
);
2180 /* System's default file type was set to binary by _fmode in emacs.c. */
2181 ofd
= creat (XSTRING (encoded_newname
)->data
, S_IREAD
| S_IWRITE
);
2182 #else /* not MSDOS */
2183 ofd
= creat (XSTRING (encoded_newname
)->data
, 0666);
2184 #endif /* not MSDOS */
2187 report_file_error ("Opening output file", Fcons (newname
, Qnil
));
2189 record_unwind_protect (close_file_unwind
, make_number (ofd
));
2193 while ((n
= read (ifd
, buf
, sizeof buf
)) > 0)
2194 if (write (ofd
, buf
, n
) != n
)
2195 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2198 /* Closing the output clobbers the file times on some systems. */
2199 if (close (ofd
) < 0)
2200 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2202 if (input_file_statable_p
)
2204 if (!NILP (keep_date
))
2206 EMACS_TIME atime
, mtime
;
2207 EMACS_SET_SECS_USECS (atime
, st
.st_atime
, 0);
2208 EMACS_SET_SECS_USECS (mtime
, st
.st_mtime
, 0);
2209 if (set_file_times (XSTRING (encoded_newname
)->data
,
2211 Fsignal (Qfile_date_error
,
2212 Fcons (build_string ("Cannot set file date"),
2213 Fcons (newname
, Qnil
)));
2216 chmod (XSTRING (encoded_newname
)->data
, st
.st_mode
& 07777);
2218 #if defined (__DJGPP__) && __DJGPP__ > 1
2219 /* In DJGPP v2.0 and later, fstat usually returns true file mode bits,
2220 and if it can't, it tells so. Otherwise, under MSDOS we usually
2221 get only the READ bit, which will make the copied file read-only,
2222 so it's better not to chmod at all. */
2223 if ((_djstat_flags
& _STFAIL_WRITEBIT
) == 0)
2224 chmod (XSTRING (encoded_newname
)->data
, st
.st_mode
& 07777);
2225 #endif /* DJGPP version 2 or newer */
2231 /* Discard the unwind protects. */
2232 specpdl_ptr
= specpdl
+ count
;
2238 DEFUN ("make-directory-internal", Fmake_directory_internal
,
2239 Smake_directory_internal
, 1, 1, 0,
2240 "Create a new directory named DIRECTORY.")
2242 Lisp_Object directory
;
2245 Lisp_Object handler
;
2246 Lisp_Object encoded_dir
;
2248 CHECK_STRING (directory
, 0);
2249 directory
= Fexpand_file_name (directory
, Qnil
);
2251 handler
= Ffind_file_name_handler (directory
, Qmake_directory_internal
);
2252 if (!NILP (handler
))
2253 return call2 (handler
, Qmake_directory_internal
, directory
);
2255 encoded_dir
= ENCODE_FILE (directory
);
2257 dir
= XSTRING (encoded_dir
)->data
;
2260 if (mkdir (dir
) != 0)
2262 if (mkdir (dir
, 0777) != 0)
2264 report_file_error ("Creating directory", Flist (1, &directory
));
2269 DEFUN ("delete-directory", Fdelete_directory
, Sdelete_directory
, 1, 1, "FDelete directory: ",
2270 "Delete the directory named DIRECTORY.")
2272 Lisp_Object directory
;
2275 Lisp_Object handler
;
2276 Lisp_Object encoded_dir
;
2278 CHECK_STRING (directory
, 0);
2279 directory
= Fdirectory_file_name (Fexpand_file_name (directory
, Qnil
));
2281 handler
= Ffind_file_name_handler (directory
, Qdelete_directory
);
2282 if (!NILP (handler
))
2283 return call2 (handler
, Qdelete_directory
, directory
);
2285 encoded_dir
= ENCODE_FILE (directory
);
2287 dir
= XSTRING (encoded_dir
)->data
;
2289 if (rmdir (dir
) != 0)
2290 report_file_error ("Removing directory", Flist (1, &directory
));
2295 DEFUN ("delete-file", Fdelete_file
, Sdelete_file
, 1, 1, "fDelete file: ",
2296 "Delete file named FILENAME.\n\
2297 If file has multiple names, it continues to exist with the other names.")
2299 Lisp_Object filename
;
2301 Lisp_Object handler
;
2302 Lisp_Object encoded_file
;
2304 CHECK_STRING (filename
, 0);
2305 filename
= Fexpand_file_name (filename
, Qnil
);
2307 handler
= Ffind_file_name_handler (filename
, Qdelete_file
);
2308 if (!NILP (handler
))
2309 return call2 (handler
, Qdelete_file
, filename
);
2311 encoded_file
= ENCODE_FILE (filename
);
2313 if (0 > unlink (XSTRING (encoded_file
)->data
))
2314 report_file_error ("Removing old name", Flist (1, &filename
));
2319 internal_delete_file_1 (ignore
)
2325 /* Delete file FILENAME, returning 1 if successful and 0 if failed. */
2328 internal_delete_file (filename
)
2329 Lisp_Object filename
;
2331 return NILP (internal_condition_case_1 (Fdelete_file
, filename
,
2332 Qt
, internal_delete_file_1
));
2335 DEFUN ("rename-file", Frename_file
, Srename_file
, 2, 3,
2336 "fRename file: \nFRename %s to file: \np",
2337 "Rename FILE as NEWNAME. Both args strings.\n\
2338 If file has names other than FILE, it continues to have those names.\n\
2339 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2340 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2341 A number as third arg means request confirmation if NEWNAME already exists.\n\
2342 This is what happens in interactive use with M-x.")
2343 (file
, newname
, ok_if_already_exists
)
2344 Lisp_Object file
, newname
, ok_if_already_exists
;
2347 Lisp_Object args
[2];
2349 Lisp_Object handler
;
2350 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2351 Lisp_Object encoded_file
, encoded_newname
;
2353 encoded_file
= encoded_newname
= Qnil
;
2354 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2355 CHECK_STRING (file
, 0);
2356 CHECK_STRING (newname
, 1);
2357 file
= Fexpand_file_name (file
, Qnil
);
2358 newname
= Fexpand_file_name (newname
, Qnil
);
2360 /* If the file name has special constructs in it,
2361 call the corresponding file handler. */
2362 handler
= Ffind_file_name_handler (file
, Qrename_file
);
2364 handler
= Ffind_file_name_handler (newname
, Qrename_file
);
2365 if (!NILP (handler
))
2366 RETURN_UNGCPRO (call4 (handler
, Qrename_file
,
2367 file
, newname
, ok_if_already_exists
));
2369 encoded_file
= ENCODE_FILE (file
);
2370 encoded_newname
= ENCODE_FILE (newname
);
2372 if (NILP (ok_if_already_exists
)
2373 || INTEGERP (ok_if_already_exists
))
2374 barf_or_query_if_file_exists (encoded_newname
, "rename to it",
2375 INTEGERP (ok_if_already_exists
), 0, 0);
2377 if (0 > rename (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
))
2379 if (0 > link (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
)
2380 || 0 > unlink (XSTRING (encoded_file
)->data
))
2385 Fcopy_file (file
, newname
,
2386 /* We have already prompted if it was an integer,
2387 so don't have copy-file prompt again. */
2388 NILP (ok_if_already_exists
) ? Qnil
: Qt
, Qt
);
2389 Fdelete_file (file
);
2396 report_file_error ("Renaming", Flist (2, args
));
2399 report_file_error ("Renaming", Flist (2, &file
));
2406 DEFUN ("add-name-to-file", Fadd_name_to_file
, Sadd_name_to_file
, 2, 3,
2407 "fAdd name to file: \nFName to add to %s: \np",
2408 "Give FILE additional name NEWNAME. Both args strings.\n\
2409 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2410 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2411 A number as third arg means request confirmation if NEWNAME already exists.\n\
2412 This is what happens in interactive use with M-x.")
2413 (file
, newname
, ok_if_already_exists
)
2414 Lisp_Object file
, newname
, ok_if_already_exists
;
2417 Lisp_Object args
[2];
2419 Lisp_Object handler
;
2420 Lisp_Object encoded_file
, encoded_newname
;
2421 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2423 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2424 encoded_file
= encoded_newname
= Qnil
;
2425 CHECK_STRING (file
, 0);
2426 CHECK_STRING (newname
, 1);
2427 file
= Fexpand_file_name (file
, Qnil
);
2428 newname
= Fexpand_file_name (newname
, Qnil
);
2430 /* If the file name has special constructs in it,
2431 call the corresponding file handler. */
2432 handler
= Ffind_file_name_handler (file
, Qadd_name_to_file
);
2433 if (!NILP (handler
))
2434 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2435 newname
, ok_if_already_exists
));
2437 /* If the new name has special constructs in it,
2438 call the corresponding file handler. */
2439 handler
= Ffind_file_name_handler (newname
, Qadd_name_to_file
);
2440 if (!NILP (handler
))
2441 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2442 newname
, ok_if_already_exists
));
2444 encoded_file
= ENCODE_FILE (file
);
2445 encoded_newname
= ENCODE_FILE (newname
);
2447 if (NILP (ok_if_already_exists
)
2448 || INTEGERP (ok_if_already_exists
))
2449 barf_or_query_if_file_exists (encoded_newname
, "make it a new name",
2450 INTEGERP (ok_if_already_exists
), 0, 0);
2452 unlink (XSTRING (newname
)->data
);
2453 if (0 > link (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
))
2458 report_file_error ("Adding new name", Flist (2, args
));
2460 report_file_error ("Adding new name", Flist (2, &file
));
2469 DEFUN ("make-symbolic-link", Fmake_symbolic_link
, Smake_symbolic_link
, 2, 3,
2470 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np",
2471 "Make a symbolic link to FILENAME, named LINKNAME. Both args strings.\n\
2472 Signals a `file-already-exists' error if a file LINKNAME already exists\n\
2473 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2474 A number as third arg means request confirmation if LINKNAME already exists.\n\
2475 This happens for interactive use with M-x.")
2476 (filename
, linkname
, ok_if_already_exists
)
2477 Lisp_Object filename
, linkname
, ok_if_already_exists
;
2480 Lisp_Object args
[2];
2482 Lisp_Object handler
;
2483 Lisp_Object encoded_filename
, encoded_linkname
;
2484 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2486 GCPRO4 (filename
, linkname
, encoded_filename
, encoded_linkname
);
2487 encoded_filename
= encoded_linkname
= Qnil
;
2488 CHECK_STRING (filename
, 0);
2489 CHECK_STRING (linkname
, 1);
2490 /* If the link target has a ~, we must expand it to get
2491 a truly valid file name. Otherwise, do not expand;
2492 we want to permit links to relative file names. */
2493 if (XSTRING (filename
)->data
[0] == '~')
2494 filename
= Fexpand_file_name (filename
, Qnil
);
2495 linkname
= Fexpand_file_name (linkname
, Qnil
);
2497 /* If the file name has special constructs in it,
2498 call the corresponding file handler. */
2499 handler
= Ffind_file_name_handler (filename
, Qmake_symbolic_link
);
2500 if (!NILP (handler
))
2501 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2502 linkname
, ok_if_already_exists
));
2504 /* If the new link name has special constructs in it,
2505 call the corresponding file handler. */
2506 handler
= Ffind_file_name_handler (linkname
, Qmake_symbolic_link
);
2507 if (!NILP (handler
))
2508 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2509 linkname
, ok_if_already_exists
));
2511 encoded_filename
= ENCODE_FILE (filename
);
2512 encoded_linkname
= ENCODE_FILE (linkname
);
2514 if (NILP (ok_if_already_exists
)
2515 || INTEGERP (ok_if_already_exists
))
2516 barf_or_query_if_file_exists (encoded_linkname
, "make it a link",
2517 INTEGERP (ok_if_already_exists
), 0, 0);
2518 if (0 > symlink (XSTRING (encoded_filename
)->data
,
2519 XSTRING (encoded_linkname
)->data
))
2521 /* If we didn't complain already, silently delete existing file. */
2522 if (errno
== EEXIST
)
2524 unlink (XSTRING (encoded_linkname
)->data
);
2525 if (0 <= symlink (XSTRING (encoded_filename
)->data
,
2526 XSTRING (encoded_linkname
)->data
))
2536 report_file_error ("Making symbolic link", Flist (2, args
));
2538 report_file_error ("Making symbolic link", Flist (2, &filename
));
2544 #endif /* S_IFLNK */
2548 DEFUN ("define-logical-name", Fdefine_logical_name
, Sdefine_logical_name
,
2549 2, 2, "sDefine logical name: \nsDefine logical name %s as: ",
2550 "Define the job-wide logical name NAME to have the value STRING.\n\
2551 If STRING is nil or a null string, the logical name NAME is deleted.")
2556 CHECK_STRING (name
, 0);
2558 delete_logical_name (XSTRING (name
)->data
);
2561 CHECK_STRING (string
, 1);
2563 if (XSTRING (string
)->size
== 0)
2564 delete_logical_name (XSTRING (name
)->data
);
2566 define_logical_name (XSTRING (name
)->data
, XSTRING (string
)->data
);
2575 DEFUN ("sysnetunam", Fsysnetunam
, Ssysnetunam
, 2, 2, 0,
2576 "Open a network connection to PATH using LOGIN as the login string.")
2578 Lisp_Object path
, login
;
2582 CHECK_STRING (path
, 0);
2583 CHECK_STRING (login
, 0);
2585 netresult
= netunam (XSTRING (path
)->data
, XSTRING (login
)->data
);
2587 if (netresult
== -1)
2592 #endif /* HPUX_NET */
2594 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p
, Sfile_name_absolute_p
,
2596 "Return t if file FILENAME specifies an absolute file name.\n\
2597 On Unix, this is a name starting with a `/' or a `~'.")
2599 Lisp_Object filename
;
2603 CHECK_STRING (filename
, 0);
2604 ptr
= XSTRING (filename
)->data
;
2605 if (IS_DIRECTORY_SEP (*ptr
) || *ptr
== '~'
2607 /* ??? This criterion is probably wrong for '<'. */
2608 || index (ptr
, ':') || index (ptr
, '<')
2609 || (*ptr
== '[' && (ptr
[1] != '-' || (ptr
[2] != '.' && ptr
[2] != ']'))
2613 || (IS_DRIVE (*ptr
) && ptr
[1] == ':' && IS_DIRECTORY_SEP (ptr
[2]))
2621 /* Return nonzero if file FILENAME exists and can be executed. */
2624 check_executable (filename
)
2628 int len
= strlen (filename
);
2631 if (stat (filename
, &st
) < 0)
2633 #if defined (WINDOWSNT) || (defined (MSDOS) && __DJGPP__ > 1)
2634 return ((st
.st_mode
& S_IEXEC
) != 0);
2636 return (S_ISREG (st
.st_mode
)
2638 && (stricmp ((suffix
= filename
+ len
-4), ".com") == 0
2639 || stricmp (suffix
, ".exe") == 0
2640 || stricmp (suffix
, ".bat") == 0)
2641 || (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2642 #endif /* not WINDOWSNT */
2643 #else /* not DOS_NT */
2644 #ifdef HAVE_EUIDACCESS
2645 return (euidaccess (filename
, 1) >= 0);
2647 /* Access isn't quite right because it uses the real uid
2648 and we really want to test with the effective uid.
2649 But Unix doesn't give us a right way to do it. */
2650 return (access (filename
, 1) >= 0);
2652 #endif /* not DOS_NT */
2655 /* Return nonzero if file FILENAME exists and can be written. */
2658 check_writable (filename
)
2663 if (stat (filename
, &st
) < 0)
2665 return (st
.st_mode
& S_IWRITE
|| (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2666 #else /* not MSDOS */
2667 #ifdef HAVE_EUIDACCESS
2668 return (euidaccess (filename
, 2) >= 0);
2670 /* Access isn't quite right because it uses the real uid
2671 and we really want to test with the effective uid.
2672 But Unix doesn't give us a right way to do it.
2673 Opening with O_WRONLY could work for an ordinary file,
2674 but would lose for directories. */
2675 return (access (filename
, 2) >= 0);
2677 #endif /* not MSDOS */
2680 DEFUN ("file-exists-p", Ffile_exists_p
, Sfile_exists_p
, 1, 1, 0,
2681 "Return t if file FILENAME exists. (This does not mean you can read it.)\n\
2682 See also `file-readable-p' and `file-attributes'.")
2684 Lisp_Object filename
;
2686 Lisp_Object absname
;
2687 Lisp_Object handler
;
2688 struct stat statbuf
;
2690 CHECK_STRING (filename
, 0);
2691 absname
= Fexpand_file_name (filename
, Qnil
);
2693 /* If the file name has special constructs in it,
2694 call the corresponding file handler. */
2695 handler
= Ffind_file_name_handler (absname
, Qfile_exists_p
);
2696 if (!NILP (handler
))
2697 return call2 (handler
, Qfile_exists_p
, absname
);
2699 absname
= ENCODE_FILE (absname
);
2701 return (stat (XSTRING (absname
)->data
, &statbuf
) >= 0) ? Qt
: Qnil
;
2704 DEFUN ("file-executable-p", Ffile_executable_p
, Sfile_executable_p
, 1, 1, 0,
2705 "Return t if FILENAME can be executed by you.\n\
2706 For a directory, this means you can access files in that directory.")
2708 Lisp_Object filename
;
2711 Lisp_Object absname
;
2712 Lisp_Object handler
;
2714 CHECK_STRING (filename
, 0);
2715 absname
= Fexpand_file_name (filename
, Qnil
);
2717 /* If the file name has special constructs in it,
2718 call the corresponding file handler. */
2719 handler
= Ffind_file_name_handler (absname
, Qfile_executable_p
);
2720 if (!NILP (handler
))
2721 return call2 (handler
, Qfile_executable_p
, absname
);
2723 absname
= ENCODE_FILE (absname
);
2725 return (check_executable (XSTRING (absname
)->data
) ? Qt
: Qnil
);
2728 DEFUN ("file-readable-p", Ffile_readable_p
, Sfile_readable_p
, 1, 1, 0,
2729 "Return t if file FILENAME exists and you can read it.\n\
2730 See also `file-exists-p' and `file-attributes'.")
2732 Lisp_Object filename
;
2734 Lisp_Object absname
;
2735 Lisp_Object handler
;
2738 struct stat statbuf
;
2740 CHECK_STRING (filename
, 0);
2741 absname
= Fexpand_file_name (filename
, Qnil
);
2743 /* If the file name has special constructs in it,
2744 call the corresponding file handler. */
2745 handler
= Ffind_file_name_handler (absname
, Qfile_readable_p
);
2746 if (!NILP (handler
))
2747 return call2 (handler
, Qfile_readable_p
, absname
);
2749 absname
= ENCODE_FILE (absname
);
2752 /* Under MS-DOS and Windows, open does not work for directories. */
2753 if (access (XSTRING (absname
)->data
, 0) == 0)
2756 #else /* not DOS_NT */
2758 #if defined (S_ISFIFO) && defined (O_NONBLOCK)
2759 /* Opening a fifo without O_NONBLOCK can wait.
2760 We don't want to wait. But we don't want to mess wth O_NONBLOCK
2761 except in the case of a fifo, on a system which handles it. */
2762 desc
= stat (XSTRING (absname
)->data
, &statbuf
);
2765 if (S_ISFIFO (statbuf
.st_mode
))
2766 flags
|= O_NONBLOCK
;
2768 desc
= open (XSTRING (absname
)->data
, flags
);
2773 #endif /* not DOS_NT */
2776 /* Having this before file-symlink-p mysteriously caused it to be forgotten
2778 DEFUN ("file-writable-p", Ffile_writable_p
, Sfile_writable_p
, 1, 1, 0,
2779 "Return t if file FILENAME can be written or created by you.")
2781 Lisp_Object filename
;
2783 Lisp_Object absname
, dir
, encoded
;
2784 Lisp_Object handler
;
2785 struct stat statbuf
;
2787 CHECK_STRING (filename
, 0);
2788 absname
= Fexpand_file_name (filename
, Qnil
);
2790 /* If the file name has special constructs in it,
2791 call the corresponding file handler. */
2792 handler
= Ffind_file_name_handler (absname
, Qfile_writable_p
);
2793 if (!NILP (handler
))
2794 return call2 (handler
, Qfile_writable_p
, absname
);
2796 encoded
= ENCODE_FILE (absname
);
2797 if (stat (XSTRING (encoded
)->data
, &statbuf
) >= 0)
2798 return (check_writable (XSTRING (encoded
)->data
)
2801 dir
= Ffile_name_directory (absname
);
2804 dir
= Fdirectory_file_name (dir
);
2808 dir
= Fdirectory_file_name (dir
);
2811 dir
= ENCODE_FILE (dir
);
2812 return (check_writable (!NILP (dir
) ? (char *) XSTRING (dir
)->data
: "")
2816 DEFUN ("access-file", Faccess_file
, Saccess_file
, 2, 2, 0,
2817 "Access file FILENAME, and get an error if that does not work.\n\
2818 The second argument STRING is used in the error message.\n\
2819 If there is no error, we return nil.")
2821 Lisp_Object filename
, string
;
2823 Lisp_Object handler
, encoded_filename
;
2826 CHECK_STRING (filename
, 0);
2828 /* If the file name has special constructs in it,
2829 call the corresponding file handler. */
2830 handler
= Ffind_file_name_handler (filename
, Qaccess_file
);
2831 if (!NILP (handler
))
2832 return call3 (handler
, Qaccess_file
, filename
, string
);
2834 encoded_filename
= ENCODE_FILE (filename
);
2836 fd
= open (XSTRING (encoded_filename
)->data
, O_RDONLY
);
2838 report_file_error (XSTRING (string
)->data
, Fcons (filename
, Qnil
));
2844 DEFUN ("file-symlink-p", Ffile_symlink_p
, Sfile_symlink_p
, 1, 1, 0,
2845 "Return non-nil if file FILENAME is the name of a symbolic link.\n\
2846 The value is the name of the file to which it is linked.\n\
2847 Otherwise returns nil.")
2849 Lisp_Object filename
;
2856 Lisp_Object handler
;
2858 CHECK_STRING (filename
, 0);
2859 filename
= Fexpand_file_name (filename
, Qnil
);
2861 /* If the file name has special constructs in it,
2862 call the corresponding file handler. */
2863 handler
= Ffind_file_name_handler (filename
, Qfile_symlink_p
);
2864 if (!NILP (handler
))
2865 return call2 (handler
, Qfile_symlink_p
, filename
);
2867 filename
= ENCODE_FILE (filename
);
2872 buf
= (char *) xmalloc (bufsize
);
2873 bzero (buf
, bufsize
);
2874 valsize
= readlink (XSTRING (filename
)->data
, buf
, bufsize
);
2875 if (valsize
< bufsize
) break;
2876 /* Buffer was not long enough */
2885 val
= make_string (buf
, valsize
);
2887 val
= DECODE_FILE (val
);
2889 #else /* not S_IFLNK */
2891 #endif /* not S_IFLNK */
2894 DEFUN ("file-directory-p", Ffile_directory_p
, Sfile_directory_p
, 1, 1, 0,
2895 "Return t if FILENAME names an existing directory.")
2897 Lisp_Object filename
;
2899 register Lisp_Object absname
;
2901 Lisp_Object handler
;
2903 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2905 /* If the file name has special constructs in it,
2906 call the corresponding file handler. */
2907 handler
= Ffind_file_name_handler (absname
, Qfile_directory_p
);
2908 if (!NILP (handler
))
2909 return call2 (handler
, Qfile_directory_p
, absname
);
2911 absname
= ENCODE_FILE (absname
);
2913 if (stat (XSTRING (absname
)->data
, &st
) < 0)
2915 return (st
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
2918 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p
, Sfile_accessible_directory_p
, 1, 1, 0,
2919 "Return t if file FILENAME is the name of a directory as a file,\n\
2920 and files in that directory can be opened by you. In order to use a\n\
2921 directory as a buffer's current directory, this predicate must return true.\n\
2922 A directory name spec may be given instead; then the value is t\n\
2923 if the directory so specified exists and really is a readable and\n\
2924 searchable directory.")
2926 Lisp_Object filename
;
2928 Lisp_Object handler
;
2930 struct gcpro gcpro1
;
2932 /* If the file name has special constructs in it,
2933 call the corresponding file handler. */
2934 handler
= Ffind_file_name_handler (filename
, Qfile_accessible_directory_p
);
2935 if (!NILP (handler
))
2936 return call2 (handler
, Qfile_accessible_directory_p
, filename
);
2938 /* It's an unlikely combination, but yes we really do need to gcpro:
2939 Suppose that file-accessible-directory-p has no handler, but
2940 file-directory-p does have a handler; this handler causes a GC which
2941 relocates the string in `filename'; and finally file-directory-p
2942 returns non-nil. Then we would end up passing a garbaged string
2943 to file-executable-p. */
2945 tem
= (NILP (Ffile_directory_p (filename
))
2946 || NILP (Ffile_executable_p (filename
)));
2948 return tem
? Qnil
: Qt
;
2951 DEFUN ("file-regular-p", Ffile_regular_p
, Sfile_regular_p
, 1, 1, 0,
2952 "Return t if file FILENAME is the name of a regular file.\n\
2953 This is the sort of file that holds an ordinary stream of data bytes.")
2955 Lisp_Object filename
;
2957 register Lisp_Object absname
;
2959 Lisp_Object handler
;
2961 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2963 /* If the file name has special constructs in it,
2964 call the corresponding file handler. */
2965 handler
= Ffind_file_name_handler (absname
, Qfile_regular_p
);
2966 if (!NILP (handler
))
2967 return call2 (handler
, Qfile_regular_p
, absname
);
2969 absname
= ENCODE_FILE (absname
);
2971 if (stat (XSTRING (absname
)->data
, &st
) < 0)
2973 return (st
.st_mode
& S_IFMT
) == S_IFREG
? Qt
: Qnil
;
2976 DEFUN ("file-modes", Ffile_modes
, Sfile_modes
, 1, 1, 0,
2977 "Return mode bits of file named FILENAME, as an integer.")
2979 Lisp_Object filename
;
2981 Lisp_Object absname
;
2983 Lisp_Object handler
;
2985 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2987 /* If the file name has special constructs in it,
2988 call the corresponding file handler. */
2989 handler
= Ffind_file_name_handler (absname
, Qfile_modes
);
2990 if (!NILP (handler
))
2991 return call2 (handler
, Qfile_modes
, absname
);
2993 absname
= ENCODE_FILE (absname
);
2995 if (stat (XSTRING (absname
)->data
, &st
) < 0)
2997 #if defined (MSDOS) && __DJGPP__ < 2
2998 if (check_executable (XSTRING (absname
)->data
))
2999 st
.st_mode
|= S_IEXEC
;
3000 #endif /* MSDOS && __DJGPP__ < 2 */
3002 return make_number (st
.st_mode
& 07777);
3005 DEFUN ("set-file-modes", Fset_file_modes
, Sset_file_modes
, 2, 2, 0,
3006 "Set mode bits of file named FILENAME to MODE (an integer).\n\
3007 Only the 12 low bits of MODE are used.")
3009 Lisp_Object filename
, mode
;
3011 Lisp_Object absname
, encoded_absname
;
3012 Lisp_Object handler
;
3014 absname
= Fexpand_file_name (filename
, current_buffer
->directory
);
3015 CHECK_NUMBER (mode
, 1);
3017 /* If the file name has special constructs in it,
3018 call the corresponding file handler. */
3019 handler
= Ffind_file_name_handler (absname
, Qset_file_modes
);
3020 if (!NILP (handler
))
3021 return call3 (handler
, Qset_file_modes
, absname
, mode
);
3023 encoded_absname
= ENCODE_FILE (absname
);
3025 if (chmod (XSTRING (encoded_absname
)->data
, XINT (mode
)) < 0)
3026 report_file_error ("Doing chmod", Fcons (absname
, Qnil
));
3031 DEFUN ("set-default-file-modes", Fset_default_file_modes
, Sset_default_file_modes
, 1, 1, 0,
3032 "Set the file permission bits for newly created files.\n\
3033 The argument MODE should be an integer; only the low 9 bits are used.\n\
3034 This setting is inherited by subprocesses.")
3038 CHECK_NUMBER (mode
, 0);
3040 umask ((~ XINT (mode
)) & 0777);
3045 DEFUN ("default-file-modes", Fdefault_file_modes
, Sdefault_file_modes
, 0, 0, 0,
3046 "Return the default file protection for created files.\n\
3047 The value is an integer.")
3053 realmask
= umask (0);
3056 XSETINT (value
, (~ realmask
) & 0777);
3062 DEFUN ("unix-sync", Funix_sync
, Sunix_sync
, 0, 0, "",
3063 "Tell Unix to finish all pending disk updates.")
3072 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p
, Sfile_newer_than_file_p
, 2, 2, 0,
3073 "Return t if file FILE1 is newer than file FILE2.\n\
3074 If FILE1 does not exist, the answer is nil;\n\
3075 otherwise, if FILE2 does not exist, the answer is t.")
3077 Lisp_Object file1
, file2
;
3079 Lisp_Object absname1
, absname2
;
3082 Lisp_Object handler
;
3083 struct gcpro gcpro1
, gcpro2
;
3085 CHECK_STRING (file1
, 0);
3086 CHECK_STRING (file2
, 0);
3089 GCPRO2 (absname1
, file2
);
3090 absname1
= expand_and_dir_to_file (file1
, current_buffer
->directory
);
3091 absname2
= expand_and_dir_to_file (file2
, current_buffer
->directory
);
3094 /* If the file name has special constructs in it,
3095 call the corresponding file handler. */
3096 handler
= Ffind_file_name_handler (absname1
, Qfile_newer_than_file_p
);
3098 handler
= Ffind_file_name_handler (absname2
, Qfile_newer_than_file_p
);
3099 if (!NILP (handler
))
3100 return call3 (handler
, Qfile_newer_than_file_p
, absname1
, absname2
);
3102 GCPRO2 (absname1
, absname2
);
3103 absname1
= ENCODE_FILE (absname1
);
3104 absname2
= ENCODE_FILE (absname2
);
3107 if (stat (XSTRING (absname1
)->data
, &st
) < 0)
3110 mtime1
= st
.st_mtime
;
3112 if (stat (XSTRING (absname2
)->data
, &st
) < 0)
3115 return (mtime1
> st
.st_mtime
) ? Qt
: Qnil
;
3119 Lisp_Object Qfind_buffer_file_type
;
3122 #ifndef READ_BUF_SIZE
3123 #define READ_BUF_SIZE (64 << 10)
3126 DEFUN ("insert-file-contents", Finsert_file_contents
, Sinsert_file_contents
,
3128 "Insert contents of file FILENAME after point.\n\
3129 Returns list of absolute file name and number of bytes inserted.\n\
3130 If second argument VISIT is non-nil, the buffer's visited filename\n\
3131 and last save file modtime are set, and it is marked unmodified.\n\
3132 If visiting and the file does not exist, visiting is completed\n\
3133 before the error is signaled.\n\
3134 The optional third and fourth arguments BEG and END\n\
3135 specify what portion of the file to insert.\n\
3136 These arguments count bytes in the file, not characters in the buffer.\n\
3137 If VISIT is non-nil, BEG and END must be nil.\n\
3139 If optional fifth argument REPLACE is non-nil,\n\
3140 it means replace the current buffer contents (in the accessible portion)\n\
3141 with the file contents. This is better than simply deleting and inserting\n\
3142 the whole thing because (1) it preserves some marker positions\n\
3143 and (2) it puts less data in the undo list.\n\
3144 When REPLACE is non-nil, the value is the number of characters actually read,\n\
3145 which is often less than the number of characters to be read.\n\
3146 This does code conversion according to the value of\n\
3147 `coding-system-for-read' or `file-coding-system-alist',\n\
3148 and sets the variable `last-coding-system-used' to the coding system\n\
3150 (filename
, visit
, beg
, end
, replace
)
3151 Lisp_Object filename
, visit
, beg
, end
, replace
;
3156 register int how_much
;
3157 register int unprocessed
;
3158 int count
= specpdl_ptr
- specpdl
;
3159 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
3160 Lisp_Object handler
, val
, insval
, orig_filename
;
3163 int not_regular
= 0;
3164 char read_buf
[READ_BUF_SIZE
];
3165 struct coding_system coding
;
3166 unsigned char buffer
[1 << 14];
3167 int replace_handled
= 0;
3168 int set_coding_system
= 0;
3170 if (current_buffer
->base_buffer
&& ! NILP (visit
))
3171 error ("Cannot do file visiting in an indirect buffer");
3173 if (!NILP (current_buffer
->read_only
))
3174 Fbarf_if_buffer_read_only ();
3178 orig_filename
= Qnil
;
3180 GCPRO4 (filename
, val
, p
, orig_filename
);
3182 CHECK_STRING (filename
, 0);
3183 filename
= Fexpand_file_name (filename
, Qnil
);
3185 /* If the file name has special constructs in it,
3186 call the corresponding file handler. */
3187 handler
= Ffind_file_name_handler (filename
, Qinsert_file_contents
);
3188 if (!NILP (handler
))
3190 val
= call6 (handler
, Qinsert_file_contents
, filename
,
3191 visit
, beg
, end
, replace
);
3195 orig_filename
= filename
;
3196 filename
= ENCODE_FILE (filename
);
3201 if (stat (XSTRING (filename
)->data
, &st
) < 0)
3203 if ((fd
= open (XSTRING (filename
)->data
, O_RDONLY
)) < 0
3204 || fstat (fd
, &st
) < 0)
3205 #endif /* not APOLLO */
3207 if (fd
>= 0) close (fd
);
3210 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
3213 if (!NILP (Vcoding_system_for_read
))
3214 current_buffer
->buffer_file_coding_system
= Vcoding_system_for_read
;
3219 /* This code will need to be changed in order to work on named
3220 pipes, and it's probably just not worth it. So we should at
3221 least signal an error. */
3222 if (!S_ISREG (st
.st_mode
))
3229 if (! NILP (replace
) || ! NILP (beg
) || ! NILP (end
))
3230 Fsignal (Qfile_error
,
3231 Fcons (build_string ("not a regular file"),
3232 Fcons (orig_filename
, Qnil
)));
3237 if ((fd
= open (XSTRING (filename
)->data
, O_RDONLY
)) < 0)
3240 /* Replacement should preserve point as it preserves markers. */
3241 if (!NILP (replace
))
3242 record_unwind_protect (restore_point_unwind
, Fpoint_marker ());
3244 record_unwind_protect (close_file_unwind
, make_number (fd
));
3246 /* Supposedly happens on VMS. */
3247 if (! not_regular
&& st
.st_size
< 0)
3248 error ("File size is negative");
3250 if (!NILP (beg
) || !NILP (end
))
3252 error ("Attempt to visit less than an entire file");
3255 CHECK_NUMBER (beg
, 0);
3257 XSETFASTINT (beg
, 0);
3260 CHECK_NUMBER (end
, 0);
3265 XSETINT (end
, st
.st_size
);
3266 if (XINT (end
) != st
.st_size
)
3267 error ("Maximum buffer size exceeded");
3271 /* Decide the coding-system of the file. */
3273 Lisp_Object val
= Qnil
;
3275 if (!NILP (Vcoding_system_for_read
))
3276 val
= Vcoding_system_for_read
;
3279 if (! NILP (Vset_auto_coding_function
))
3281 /* Find a coding system specified in the heading two lines
3282 or in the tailing several lines of the file. We assume
3283 that the 1K-byte and 3K-byte for heading and tailing
3284 respectively are sufficient fot this purpose. */
3285 int how_many
, nread
;
3287 if (st
.st_size
<= (1024 * 4))
3288 nread
= read (fd
, read_buf
, 1024 * 4);
3291 nread
= read (fd
, read_buf
, 1024);
3294 if (lseek (fd
, st
.st_size
- (1024 * 3), 0) < 0)
3295 report_file_error ("Setting file position",
3296 Fcons (orig_filename
, Qnil
));
3297 nread
+= read (fd
, read_buf
+ nread
, 1024 * 3);
3302 error ("IO error reading %s: %s",
3303 XSTRING (orig_filename
)->data
, strerror (errno
));
3307 /* Always make this a unibyte string
3308 because we have not yet decoded it. */
3309 tem
= make_unibyte_string (read_buf
, nread
);
3310 val
= call1 (Vset_auto_coding_function
, tem
);
3311 /* Rewind the file for the actual read done later. */
3312 if (lseek (fd
, 0, 0) < 0)
3313 report_file_error ("Setting file position",
3314 Fcons (orig_filename
, Qnil
));
3319 Lisp_Object args
[6], coding_systems
;
3321 args
[0] = Qinsert_file_contents
, args
[1] = orig_filename
,
3322 args
[2] = visit
, args
[3] = beg
, args
[4] = end
, args
[5] = replace
;
3323 coding_systems
= Ffind_operation_coding_system (6, args
);
3324 if (CONSP (coding_systems
)) val
= XCONS (coding_systems
)->car
;
3328 if (NILP (Vcoding_system_for_read
)
3329 && NILP (current_buffer
->enable_multibyte_characters
))
3331 /* We must suppress all text conversion except for end-of-line
3333 struct coding_system coding_temp
;
3335 setup_coding_system (Fcheck_coding_system (val
), &coding_temp
);
3336 setup_coding_system (Qraw_text
, &coding
);
3337 coding
.eol_type
= coding_temp
.eol_type
;
3340 setup_coding_system (Fcheck_coding_system (val
), &coding
);
3343 /* If requested, replace the accessible part of the buffer
3344 with the file contents. Avoid replacing text at the
3345 beginning or end of the buffer that matches the file contents;
3346 that preserves markers pointing to the unchanged parts.
3348 Here we implement this feature in an optimized way
3349 for the case where code conversion is NOT needed.
3350 The following if-statement handles the case of conversion
3351 in a less optimal way.
3353 If the code conversion is "automatic" then we try using this
3354 method and hope for the best.
3355 But if we discover the need for conversion, we give up on this method
3356 and let the following if-statement handle the replace job. */
3358 && ! CODING_REQUIRE_DECODING (&coding
))
3360 /* same_at_start and same_at_end count bytes,
3361 because file access counts bytes
3362 and BEG and END count bytes. */
3363 int same_at_start
= BEGV_BYTE
;
3364 int same_at_end
= ZV_BYTE
;
3366 /* There is still a possibility we will find the need to do code
3367 conversion. If that happens, we set this variable to 1 to
3368 give up on handling REPLACE in the optimized way. */
3369 int giveup_match_end
= 0;
3371 if (XINT (beg
) != 0)
3373 if (lseek (fd
, XINT (beg
), 0) < 0)
3374 report_file_error ("Setting file position",
3375 Fcons (orig_filename
, Qnil
));
3380 /* Count how many chars at the start of the file
3381 match the text at the beginning of the buffer. */
3386 nread
= read (fd
, buffer
, sizeof buffer
);
3388 error ("IO error reading %s: %s",
3389 XSTRING (orig_filename
)->data
, strerror (errno
));
3390 else if (nread
== 0)
3393 if (coding
.type
== coding_type_undecided
)
3394 detect_coding (&coding
, buffer
, nread
);
3395 if (CODING_REQUIRE_DECODING (&coding
))
3396 /* We found that the file should be decoded somehow.
3397 Let's give up here. */
3399 giveup_match_end
= 1;
3403 if (coding
.eol_type
== CODING_EOL_UNDECIDED
)
3404 detect_eol (&coding
, buffer
, nread
);
3405 if (coding
.eol_type
!= CODING_EOL_UNDECIDED
3406 && coding
.eol_type
!= CODING_EOL_LF
)
3407 /* We found that the format of eol should be decoded.
3408 Let's give up here. */
3410 giveup_match_end
= 1;
3415 while (bufpos
< nread
&& same_at_start
< ZV_BYTE
3416 && FETCH_BYTE (same_at_start
) == buffer
[bufpos
])
3417 same_at_start
++, bufpos
++;
3418 /* If we found a discrepancy, stop the scan.
3419 Otherwise loop around and scan the next bufferful. */
3420 if (bufpos
!= nread
)
3424 /* If the file matches the buffer completely,
3425 there's no need to replace anything. */
3426 if (same_at_start
- BEGV_BYTE
== XINT (end
))
3430 /* Truncate the buffer to the size of the file. */
3431 del_range_1 (same_at_start
, same_at_end
, 0);
3436 /* Count how many chars at the end of the file
3437 match the text at the end of the buffer. But, if we have
3438 already found that decoding is necessary, don't waste time. */
3439 while (!giveup_match_end
)
3441 int total_read
, nread
, bufpos
, curpos
, trial
;
3443 /* At what file position are we now scanning? */
3444 curpos
= XINT (end
) - (ZV_BYTE
- same_at_end
);
3445 /* If the entire file matches the buffer tail, stop the scan. */
3448 /* How much can we scan in the next step? */
3449 trial
= min (curpos
, sizeof buffer
);
3450 if (lseek (fd
, curpos
- trial
, 0) < 0)
3451 report_file_error ("Setting file position",
3452 Fcons (orig_filename
, Qnil
));
3455 while (total_read
< trial
)
3457 nread
= read (fd
, buffer
+ total_read
, trial
- total_read
);
3459 error ("IO error reading %s: %s",
3460 XSTRING (orig_filename
)->data
, strerror (errno
));
3461 total_read
+= nread
;
3463 /* Scan this bufferful from the end, comparing with
3464 the Emacs buffer. */
3465 bufpos
= total_read
;
3466 /* Compare with same_at_start to avoid counting some buffer text
3467 as matching both at the file's beginning and at the end. */
3468 while (bufpos
> 0 && same_at_end
> same_at_start
3469 && FETCH_BYTE (same_at_end
- 1) == buffer
[bufpos
- 1])
3470 same_at_end
--, bufpos
--;
3472 /* If we found a discrepancy, stop the scan.
3473 Otherwise loop around and scan the preceding bufferful. */
3476 /* If this discrepancy is because of code conversion,
3477 we cannot use this method; giveup and try the other. */
3478 if (same_at_end
> same_at_start
3479 && FETCH_BYTE (same_at_end
- 1) >= 0200
3480 && ! NILP (current_buffer
->enable_multibyte_characters
)
3481 && (CODING_MAY_REQUIRE_DECODING (&coding
)))
3482 giveup_match_end
= 1;
3488 if (! giveup_match_end
)
3492 /* We win! We can handle REPLACE the optimized way. */
3494 /* Extends the end of non-matching text area to multibyte
3495 character boundary. */
3496 if (! NILP (current_buffer
->enable_multibyte_characters
))
3497 while (same_at_end
< ZV_BYTE
3498 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_end
)))
3501 /* Don't try to reuse the same piece of text twice. */
3502 overlap
= (same_at_start
- BEGV_BYTE
3503 - (same_at_end
+ st
.st_size
- ZV
));
3505 same_at_end
+= overlap
;
3507 /* Arrange to read only the nonmatching middle part of the file. */
3508 XSETFASTINT (beg
, XINT (beg
) + (same_at_start
- BEGV_BYTE
));
3509 XSETFASTINT (end
, XINT (end
) - (ZV_BYTE
- same_at_end
));
3511 del_range_byte (same_at_start
, same_at_end
, 0);
3512 /* Insert from the file at the proper position. */
3513 temp
= BYTE_TO_CHAR (same_at_start
);
3514 SET_PT_BOTH (temp
, same_at_start
);
3516 /* If display currently starts at beginning of line,
3517 keep it that way. */
3518 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3519 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3521 replace_handled
= 1;
3525 /* If requested, replace the accessible part of the buffer
3526 with the file contents. Avoid replacing text at the
3527 beginning or end of the buffer that matches the file contents;
3528 that preserves markers pointing to the unchanged parts.
3530 Here we implement this feature for the case where code conversion
3531 is needed, in a simple way that needs a lot of memory.
3532 The preceding if-statement handles the case of no conversion
3533 in a more optimized way. */
3534 if (!NILP (replace
) && ! replace_handled
)
3536 int same_at_start
= BEGV_BYTE
;
3537 int same_at_end
= ZV_BYTE
;
3540 /* Make sure that the gap is large enough. */
3541 int bufsize
= 2 * st
.st_size
;
3542 unsigned char *conversion_buffer
= (unsigned char *) xmalloc (bufsize
);
3545 /* First read the whole file, performing code conversion into
3546 CONVERSION_BUFFER. */
3548 if (lseek (fd
, XINT (beg
), 0) < 0)
3550 free (conversion_buffer
);
3551 report_file_error ("Setting file position",
3552 Fcons (orig_filename
, Qnil
));
3555 total
= st
.st_size
; /* Total bytes in the file. */
3556 how_much
= 0; /* Bytes read from file so far. */
3557 inserted
= 0; /* Bytes put into CONVERSION_BUFFER so far. */
3558 unprocessed
= 0; /* Bytes not processed in previous loop. */
3560 while (how_much
< total
)
3562 /* try is reserved in some compilers (Microsoft C) */
3563 int trytry
= min (total
- how_much
, READ_BUF_SIZE
- unprocessed
);
3564 char *destination
= read_buf
+ unprocessed
;
3567 /* Allow quitting out of the actual I/O. */
3570 this = read (fd
, destination
, trytry
);
3573 if (this < 0 || this + unprocessed
== 0)
3581 if (CODING_MAY_REQUIRE_DECODING (&coding
))
3583 int require
, result
;
3585 this += unprocessed
;
3587 /* If we are using more space than estimated,
3588 make CONVERSION_BUFFER bigger. */
3589 require
= decoding_buffer_size (&coding
, this);
3590 if (inserted
+ require
+ 2 * (total
- how_much
) > bufsize
)
3592 bufsize
= inserted
+ require
+ 2 * (total
- how_much
);
3593 conversion_buffer
= (unsigned char *) xrealloc (conversion_buffer
, bufsize
);
3596 /* Convert this batch with results in CONVERSION_BUFFER. */
3597 if (how_much
>= total
) /* This is the last block. */
3598 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
3599 result
= decode_coding (&coding
, read_buf
,
3600 conversion_buffer
+ inserted
,
3601 this, bufsize
- inserted
);
3603 /* Save for next iteration whatever we didn't convert. */
3604 unprocessed
= this - coding
.consumed
;
3605 bcopy (read_buf
+ coding
.consumed
, read_buf
, unprocessed
);
3606 this = coding
.produced
;
3612 /* At this point, INSERTED is how many characters (i.e. bytes)
3613 are present in CONVERSION_BUFFER.
3614 HOW_MUCH should equal TOTAL,
3615 or should be <= 0 if we couldn't read the file. */
3619 free (conversion_buffer
);
3622 error ("IO error reading %s: %s",
3623 XSTRING (orig_filename
)->data
, strerror (errno
));
3624 else if (how_much
== -2)
3625 error ("maximum buffer size exceeded");
3628 /* Compare the beginning of the converted file
3629 with the buffer text. */
3632 while (bufpos
< inserted
&& same_at_start
< same_at_end
3633 && FETCH_BYTE (same_at_start
) == conversion_buffer
[bufpos
])
3634 same_at_start
++, bufpos
++;
3636 /* If the file matches the buffer completely,
3637 there's no need to replace anything. */
3639 if (bufpos
== inserted
)
3641 free (conversion_buffer
);
3644 /* Truncate the buffer to the size of the file. */
3645 del_range_1 (same_at_start
, same_at_end
, 0);
3649 /* Scan this bufferful from the end, comparing with
3650 the Emacs buffer. */
3653 /* Compare with same_at_start to avoid counting some buffer text
3654 as matching both at the file's beginning and at the end. */
3655 while (bufpos
> 0 && same_at_end
> same_at_start
3656 && FETCH_BYTE (same_at_end
- 1) == conversion_buffer
[bufpos
- 1])
3657 same_at_end
--, bufpos
--;
3659 /* Don't try to reuse the same piece of text twice. */
3660 overlap
= same_at_start
- BEGV_BYTE
- (same_at_end
+ inserted
- ZV_BYTE
);
3662 same_at_end
+= overlap
;
3664 /* If display currently starts at beginning of line,
3665 keep it that way. */
3666 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3667 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3669 /* Replace the chars that we need to replace,
3670 and update INSERTED to equal the number of bytes
3671 we are taking from the file. */
3672 inserted
-= (Z_BYTE
- same_at_end
) + (same_at_start
- BEG_BYTE
);
3673 del_range_byte (same_at_start
, same_at_end
, 0);
3674 SET_PT_BOTH (GPT
, GPT_BYTE
);
3676 insert_1 (conversion_buffer
+ same_at_start
- BEG_BYTE
, inserted
,
3679 free (conversion_buffer
);
3688 register Lisp_Object temp
;
3690 total
= XINT (end
) - XINT (beg
);
3692 /* Make sure point-max won't overflow after this insertion. */
3693 XSETINT (temp
, total
);
3694 if (total
!= XINT (temp
))
3695 error ("Maximum buffer size exceeded");
3698 /* For a special file, all we can do is guess. */
3699 total
= READ_BUF_SIZE
;
3701 if (NILP (visit
) && total
> 0)
3702 prepare_to_modify_buffer (PT
, PT
, NULL
);
3705 if (GAP_SIZE
< total
)
3706 make_gap (total
- GAP_SIZE
);
3708 if (XINT (beg
) != 0 || !NILP (replace
))
3710 if (lseek (fd
, XINT (beg
), 0) < 0)
3711 report_file_error ("Setting file position",
3712 Fcons (orig_filename
, Qnil
));
3715 /* In the following loop, HOW_MUCH contains the total bytes read so
3716 far for a regular file, and not changed for a special file. But,
3717 before exiting the loop, it is set to a negative value if I/O
3720 /* Total bytes inserted. */
3722 /* Here, we don't do code conversion in the loop. It is done by
3723 code_convert_region after all data are read into the buffer. */
3724 while (how_much
< total
)
3726 /* try is reserved in some compilers (Microsoft C) */
3727 int trytry
= min (total
- how_much
, READ_BUF_SIZE
);
3730 /* For a special file, GAP_SIZE should be checked every time. */
3731 if (not_regular
&& GAP_SIZE
< trytry
)
3732 make_gap (total
- GAP_SIZE
);
3734 /* Allow quitting out of the actual I/O. */
3737 this = read (fd
, BYTE_POS_ADDR (PT_BYTE
+ inserted
- 1) + 1, trytry
);
3754 /* For a regular file, where TOTAL is the real size,
3755 count HOW_MUCH to compare with it.
3756 For a special file, where TOTAL is just a buffer size,
3757 so don't bother counting in HOW_MUCH.
3758 (INSERTED is where we count the number of characters inserted.) */
3765 /* Put an anchor to ensure multi-byte form ends at gap. */
3770 /* Discard the unwind protect for closing the file. */
3774 error ("IO error reading %s: %s",
3775 XSTRING (orig_filename
)->data
, strerror (errno
));
3779 if (CODING_MAY_REQUIRE_DECODING (&coding
))
3781 /* Here, we don't have to consider byte combining (see the
3782 comment below) because code_convert_region takes care of
3784 code_convert_region (PT
, PT_BYTE
, PT
+ inserted
, PT_BYTE
+ inserted
,
3786 inserted
= (NILP (current_buffer
->enable_multibyte_characters
)
3787 ? coding
.produced
: coding
.produced_char
);
3789 else if (!NILP (current_buffer
->enable_multibyte_characters
))
3791 int inserted_byte
= inserted
;
3793 /* There's a possibility that we must combine bytes at the
3794 head (resp. the tail) of the just inserted text with the
3795 bytes before (resp. after) the gap to form a single
3796 character. Thus, we, at first, rewind the adjusted
3797 character positions (GPT, ZV, Z), then adjust them again. */
3798 GAP_SIZE
+= inserted
;
3799 GPT_BYTE
-= inserted
;
3800 ZV_BYTE
-= inserted
;
3806 inserted
= multibyte_chars_in_text (GPT_ADDR
, inserted
);
3807 adjust_after_replace (PT
, PT_BYTE
, PT
, PT_BYTE
,
3808 inserted
, inserted_byte
, 0);
3812 /* Use the conversion type to determine buffer-file-type
3813 (find-buffer-file-type is now used to help determine the
3815 if (coding
.eol_type
!= CODING_EOL_UNDECIDED
3816 && coding
.eol_type
!= CODING_EOL_LF
)
3817 current_buffer
->buffer_file_type
= Qnil
;
3819 current_buffer
->buffer_file_type
= Qt
;
3823 set_coding_system
= 1;
3830 if (!EQ (current_buffer
->undo_list
, Qt
))
3831 current_buffer
->undo_list
= Qnil
;
3833 stat (XSTRING (filename
)->data
, &st
);
3838 current_buffer
->modtime
= st
.st_mtime
;
3839 current_buffer
->filename
= orig_filename
;
3842 SAVE_MODIFF
= MODIFF
;
3843 current_buffer
->auto_save_modified
= MODIFF
;
3844 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
3845 #ifdef CLASH_DETECTION
3848 if (!NILP (current_buffer
->file_truename
))
3849 unlock_file (current_buffer
->file_truename
);
3850 unlock_file (filename
);
3852 #endif /* CLASH_DETECTION */
3854 Fsignal (Qfile_error
,
3855 Fcons (build_string ("not a regular file"),
3856 Fcons (orig_filename
, Qnil
)));
3858 /* If visiting nonexistent file, return nil. */
3859 if (current_buffer
->modtime
== -1)
3860 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
3863 /* Decode file format */
3866 insval
= call3 (Qformat_decode
,
3867 Qnil
, make_number (inserted
), visit
);
3868 CHECK_NUMBER (insval
, 0);
3869 inserted
= XFASTINT (insval
);
3872 /* Call after-change hooks for the inserted text, aside from the case
3873 of normal visiting (not with REPLACE), which is done in a new buffer
3874 "before" the buffer is changed. */
3875 if (inserted
> 0 && total
> 0
3876 && (NILP (visit
) || !NILP (replace
)))
3877 signal_after_change (PT
, 0, inserted
);
3879 if (set_coding_system
)
3880 Vlast_coding_system_used
= coding
.symbol
;
3884 p
= Vafter_insert_file_functions
;
3887 insval
= call1 (Fcar (p
), make_number (inserted
));
3890 CHECK_NUMBER (insval
, 0);
3891 inserted
= XFASTINT (insval
);
3898 /* ??? Retval needs to be dealt with in all cases consistently. */
3900 val
= Fcons (orig_filename
,
3901 Fcons (make_number (inserted
),
3904 RETURN_UNGCPRO (unbind_to (count
, val
));
3907 static Lisp_Object build_annotations
P_ ((Lisp_Object
, Lisp_Object
,
3910 /* If build_annotations switched buffers, switch back to BUF.
3911 Kill the temporary buffer that was selected in the meantime.
3913 Since this kill only the last temporary buffer, some buffers remain
3914 not killed if build_annotations switched buffers more than once.
3918 build_annotations_unwind (buf
)
3923 if (XBUFFER (buf
) == current_buffer
)
3925 tembuf
= Fcurrent_buffer ();
3927 Fkill_buffer (tembuf
);
3931 DEFUN ("write-region", Fwrite_region
, Swrite_region
, 3, 7,
3932 "r\nFWrite region to file: \ni\ni\ni\np",
3933 "Write current region into specified file.\n\
3934 When called from a program, takes three arguments:\n\
3935 START, END and FILENAME. START and END are buffer positions.\n\
3936 Optional fourth argument APPEND if non-nil means\n\
3937 append to existing file contents (if any).\n\
3938 Optional fifth argument VISIT if t means\n\
3939 set the last-save-file-modtime of buffer to this file's modtime\n\
3940 and mark buffer not modified.\n\
3941 If VISIT is a string, it is a second file name;\n\
3942 the output goes to FILENAME, but the buffer is marked as visiting VISIT.\n\
3943 VISIT is also the file name to lock and unlock for clash detection.\n\
3944 If VISIT is neither t nor nil nor a string,\n\
3945 that means do not print the \"Wrote file\" message.\n\
3946 The optional sixth arg LOCKNAME, if non-nil, specifies the name to\n\
3947 use for locking and unlocking, overriding FILENAME and VISIT.\n\
3948 The optional seventh arg CONFIRM, if non-nil, says ask for confirmation\n\
3949 before overwriting an existing file.\n\
3950 Kludgy feature: if START is a string, then that string is written\n\
3951 to the file, instead of any buffer contents, and END is ignored.")
3952 (start
, end
, filename
, append
, visit
, lockname
, confirm
)
3953 Lisp_Object start
, end
, filename
, append
, visit
, lockname
, confirm
;
3961 int count
= specpdl_ptr
- specpdl
;
3964 unsigned char *fname
= 0; /* If non-0, original filename (must rename) */
3966 Lisp_Object handler
;
3967 Lisp_Object visit_file
;
3968 Lisp_Object annotations
;
3969 Lisp_Object encoded_filename
;
3970 int visiting
, quietly
;
3971 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
3972 struct buffer
*given_buffer
;
3974 int buffer_file_type
= O_BINARY
;
3976 struct coding_system coding
;
3978 if (current_buffer
->base_buffer
&& ! NILP (visit
))
3979 error ("Cannot do file visiting in an indirect buffer");
3981 if (!NILP (start
) && !STRINGP (start
))
3982 validate_region (&start
, &end
);
3984 GCPRO4 (start
, filename
, visit
, lockname
);
3986 /* Decide the coding-system to encode the data with. */
3992 else if (!NILP (Vcoding_system_for_write
))
3993 val
= Vcoding_system_for_write
;
3994 else if (NILP (current_buffer
->enable_multibyte_characters
))
3996 /* If the variable `buffer-file-coding-system' is set locally,
3997 it means that the file was read with some kind of code
3998 conversion or the varialbe is explicitely set by users. We
3999 had better write it out with the same coding system even if
4000 `enable-multibyte-characters' is nil.
4002 If it is not set locally, we anyway have to convert EOL
4003 format if the default value of `buffer-file-coding-system'
4004 tells that it is not Unix-like (LF only) format. */
4005 val
= current_buffer
->buffer_file_coding_system
;
4006 if (NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4008 struct coding_system coding_temp
;
4010 setup_coding_system (Fcheck_coding_system (val
), &coding_temp
);
4011 if (coding_temp
.eol_type
== CODING_EOL_CRLF
4012 || coding_temp
.eol_type
== CODING_EOL_CR
)
4014 setup_coding_system (Qraw_text
, &coding
);
4015 coding
.eol_type
= coding_temp
.eol_type
;
4016 goto done_setup_coding
;
4023 Lisp_Object args
[7], coding_systems
;
4025 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4026 args
[3] = filename
; args
[4] = append
; args
[5] = visit
;
4028 coding_systems
= Ffind_operation_coding_system (7, args
);
4029 val
= (CONSP (coding_systems
) && !NILP (XCONS (coding_systems
)->cdr
)
4030 ? XCONS (coding_systems
)->cdr
4031 : current_buffer
->buffer_file_coding_system
);
4032 /* Confirm that VAL can surely encode the current region. */
4033 if (Ffboundp (Vselect_safe_coding_system_function
))
4034 val
= call3 (Vselect_safe_coding_system_function
, start
, end
, val
);
4036 setup_coding_system (Fcheck_coding_system (val
), &coding
);
4039 if (!STRINGP (start
) && !NILP (current_buffer
->selective_display
))
4040 coding
.mode
|= CODING_MODE_SELECTIVE_DISPLAY
;
4043 Vlast_coding_system_used
= coding
.symbol
;
4045 filename
= Fexpand_file_name (filename
, Qnil
);
4047 if (! NILP (confirm
))
4048 barf_or_query_if_file_exists (filename
, "overwrite", 1, 0, 1);
4050 if (STRINGP (visit
))
4051 visit_file
= Fexpand_file_name (visit
, Qnil
);
4053 visit_file
= filename
;
4056 visiting
= (EQ (visit
, Qt
) || STRINGP (visit
));
4057 quietly
= !NILP (visit
);
4061 if (NILP (lockname
))
4062 lockname
= visit_file
;
4064 GCPRO5 (start
, filename
, annotations
, visit_file
, lockname
);
4066 /* If the file name has special constructs in it,
4067 call the corresponding file handler. */
4068 handler
= Ffind_file_name_handler (filename
, Qwrite_region
);
4069 /* If FILENAME has no handler, see if VISIT has one. */
4070 if (NILP (handler
) && STRINGP (visit
))
4071 handler
= Ffind_file_name_handler (visit
, Qwrite_region
);
4073 if (!NILP (handler
))
4076 val
= call6 (handler
, Qwrite_region
, start
, end
,
4077 filename
, append
, visit
);
4081 SAVE_MODIFF
= MODIFF
;
4082 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4083 current_buffer
->filename
= visit_file
;
4089 /* Special kludge to simplify auto-saving. */
4092 XSETFASTINT (start
, BEG
);
4093 XSETFASTINT (end
, Z
);
4096 record_unwind_protect (build_annotations_unwind
, Fcurrent_buffer ());
4097 count1
= specpdl_ptr
- specpdl
;
4099 given_buffer
= current_buffer
;
4100 annotations
= build_annotations (start
, end
, coding
.pre_write_conversion
);
4101 if (current_buffer
!= given_buffer
)
4103 XSETFASTINT (start
, BEGV
);
4104 XSETFASTINT (end
, ZV
);
4107 #ifdef CLASH_DETECTION
4110 #if 0 /* This causes trouble for GNUS. */
4111 /* If we've locked this file for some other buffer,
4112 query before proceeding. */
4113 if (!visiting
&& EQ (Ffile_locked_p (lockname
), Qt
))
4114 call2 (intern ("ask-user-about-lock"), filename
, Vuser_login_name
);
4117 lock_file (lockname
);
4119 #endif /* CLASH_DETECTION */
4121 encoded_filename
= ENCODE_FILE (filename
);
4123 fn
= XSTRING (encoded_filename
)->data
;
4127 desc
= open (fn
, O_WRONLY
| buffer_file_type
);
4128 #else /* not DOS_NT */
4129 desc
= open (fn
, O_WRONLY
);
4130 #endif /* not DOS_NT */
4132 if (desc
< 0 && (NILP (append
) || errno
== ENOENT
))
4134 if (auto_saving
) /* Overwrite any previous version of autosave file */
4136 vms_truncate (fn
); /* if fn exists, truncate to zero length */
4137 desc
= open (fn
, O_RDWR
);
4139 desc
= creat_copy_attrs (STRINGP (current_buffer
->filename
)
4140 ? XSTRING (current_buffer
->filename
)->data
: 0,
4143 else /* Write to temporary name and rename if no errors */
4145 Lisp_Object temp_name
;
4146 temp_name
= Ffile_name_directory (filename
);
4148 if (!NILP (temp_name
))
4150 temp_name
= Fmake_temp_name (concat2 (temp_name
,
4151 build_string ("$$SAVE$$")));
4152 fname
= XSTRING (filename
)->data
;
4153 fn
= XSTRING (temp_name
)->data
;
4154 desc
= creat_copy_attrs (fname
, fn
);
4157 /* If we can't open the temporary file, try creating a new
4158 version of the original file. VMS "creat" creates a
4159 new version rather than truncating an existing file. */
4162 desc
= creat (fn
, 0666);
4163 #if 0 /* This can clobber an existing file and fail to replace it,
4164 if the user runs out of space. */
4167 /* We can't make a new version;
4168 try to truncate and rewrite existing version if any. */
4170 desc
= open (fn
, O_RDWR
);
4176 desc
= creat (fn
, 0666);
4181 O_WRONLY
| O_TRUNC
| O_CREAT
| buffer_file_type
,
4182 S_IREAD
| S_IWRITE
);
4183 #else /* not DOS_NT */
4184 desc
= creat (fn
, auto_saving
? auto_save_mode_bits
: 0666);
4185 #endif /* not DOS_NT */
4186 #endif /* not VMS */
4192 #ifdef CLASH_DETECTION
4194 if (!auto_saving
) unlock_file (lockname
);
4196 #endif /* CLASH_DETECTION */
4197 report_file_error ("Opening output file", Fcons (filename
, Qnil
));
4200 record_unwind_protect (close_file_unwind
, make_number (desc
));
4203 if (lseek (desc
, 0, 2) < 0)
4205 #ifdef CLASH_DETECTION
4206 if (!auto_saving
) unlock_file (lockname
);
4207 #endif /* CLASH_DETECTION */
4208 report_file_error ("Lseek error", Fcons (filename
, Qnil
));
4213 * Kludge Warning: The VMS C RTL likes to insert carriage returns
4214 * if we do writes that don't end with a carriage return. Furthermore
4215 * it cannot handle writes of more then 16K. The modified
4216 * version of "sys_write" in SYSDEP.C (see comment there) copes with
4217 * this EXCEPT for the last record (iff it doesn't end with a carriage
4218 * return). This implies that if your buffer doesn't end with a carriage
4219 * return, you get one free... tough. However it also means that if
4220 * we make two calls to sys_write (a la the following code) you can
4221 * get one at the gap as well. The easiest way to fix this (honest)
4222 * is to move the gap to the next newline (or the end of the buffer).
4227 if (GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4228 move_gap (find_next_newline (GPT
, 1));
4230 /* Whether VMS or not, we must move the gap to the next of newline
4231 when we must put designation sequences at beginning of line. */
4232 if (INTEGERP (start
)
4233 && coding
.type
== coding_type_iso2022
4234 && coding
.flags
& CODING_FLAG_ISO_DESIGNATE_AT_BOL
4235 && GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4237 int opoint
= PT
, opoint_byte
= PT_BYTE
;
4238 scan_newline (PT
, PT_BYTE
, ZV
, ZV_BYTE
, 1, 0);
4239 move_gap_both (PT
, PT_BYTE
);
4240 SET_PT_BOTH (opoint
, opoint_byte
);
4247 if (STRINGP (start
))
4249 failure
= 0 > a_write (desc
, XSTRING (start
)->data
,
4250 STRING_BYTES (XSTRING (start
)), 0, &annotations
,
4254 else if (XINT (start
) != XINT (end
))
4256 register int end1
= CHAR_TO_BYTE (XINT (end
));
4258 tem
= CHAR_TO_BYTE (XINT (start
));
4260 if (XINT (start
) < GPT
)
4262 failure
= 0 > a_write (desc
, BYTE_POS_ADDR (tem
),
4263 min (GPT_BYTE
, end1
) - tem
, tem
, &annotations
,
4268 if (XINT (end
) > GPT
&& !failure
)
4270 tem
= max (tem
, GPT_BYTE
);
4271 failure
= 0 > a_write (desc
, BYTE_POS_ADDR (tem
), end1
- tem
,
4272 tem
, &annotations
, &coding
);
4278 /* If file was empty, still need to write the annotations */
4279 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4280 failure
= 0 > a_write (desc
, "", 0, XINT (start
), &annotations
, &coding
);
4284 if (CODING_REQUIRE_FLUSHING (&coding
)
4285 && !(coding
.mode
& CODING_MODE_LAST_BLOCK
)
4288 /* We have to flush out a data. */
4289 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4290 failure
= 0 > e_write (desc
, "", 0, &coding
);
4297 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
4298 Disk full in NFS may be reported here. */
4299 /* mib says that closing the file will try to write as fast as NFS can do
4300 it, and that means the fsync here is not crucial for autosave files. */
4301 if (!auto_saving
&& fsync (desc
) < 0)
4303 /* If fsync fails with EINTR, don't treat that as serious. */
4305 failure
= 1, save_errno
= errno
;
4309 /* Spurious "file has changed on disk" warnings have been
4310 observed on Suns as well.
4311 It seems that `close' can change the modtime, under nfs.
4313 (This has supposedly been fixed in Sunos 4,
4314 but who knows about all the other machines with NFS?) */
4317 /* On VMS and APOLLO, must do the stat after the close
4318 since closing changes the modtime. */
4321 /* Recall that #if defined does not work on VMS. */
4328 /* NFS can report a write failure now. */
4329 if (close (desc
) < 0)
4330 failure
= 1, save_errno
= errno
;
4333 /* If we wrote to a temporary name and had no errors, rename to real name. */
4337 failure
= (rename (fn
, fname
) != 0), save_errno
= errno
;
4345 /* Discard the unwind protect for close_file_unwind. */
4346 specpdl_ptr
= specpdl
+ count1
;
4347 /* Restore the original current buffer. */
4348 visit_file
= unbind_to (count
, visit_file
);
4350 #ifdef CLASH_DETECTION
4352 unlock_file (lockname
);
4353 #endif /* CLASH_DETECTION */
4355 /* Do this before reporting IO error
4356 to avoid a "file has changed on disk" warning on
4357 next attempt to save. */
4359 current_buffer
->modtime
= st
.st_mtime
;
4362 error ("IO error writing %s: %s", XSTRING (filename
)->data
,
4363 strerror (save_errno
));
4367 SAVE_MODIFF
= MODIFF
;
4368 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4369 current_buffer
->filename
= visit_file
;
4370 update_mode_lines
++;
4376 message_with_string ("Wrote %s", visit_file
, 1);
4381 Lisp_Object
merge ();
4383 DEFUN ("car-less-than-car", Fcar_less_than_car
, Scar_less_than_car
, 2, 2, 0,
4384 "Return t if (car A) is numerically less than (car B).")
4388 return Flss (Fcar (a
), Fcar (b
));
4391 /* Build the complete list of annotations appropriate for writing out
4392 the text between START and END, by calling all the functions in
4393 write-region-annotate-functions and merging the lists they return.
4394 If one of these functions switches to a different buffer, we assume
4395 that buffer contains altered text. Therefore, the caller must
4396 make sure to restore the current buffer in all cases,
4397 as save-excursion would do. */
4400 build_annotations (start
, end
, pre_write_conversion
)
4401 Lisp_Object start
, end
, pre_write_conversion
;
4403 Lisp_Object annotations
;
4405 struct gcpro gcpro1
, gcpro2
;
4406 Lisp_Object original_buffer
;
4408 XSETBUFFER (original_buffer
, current_buffer
);
4411 p
= Vwrite_region_annotate_functions
;
4412 GCPRO2 (annotations
, p
);
4415 struct buffer
*given_buffer
= current_buffer
;
4416 Vwrite_region_annotations_so_far
= annotations
;
4417 res
= call2 (Fcar (p
), start
, end
);
4418 /* If the function makes a different buffer current,
4419 assume that means this buffer contains altered text to be output.
4420 Reset START and END from the buffer bounds
4421 and discard all previous annotations because they should have
4422 been dealt with by this function. */
4423 if (current_buffer
!= given_buffer
)
4425 XSETFASTINT (start
, BEGV
);
4426 XSETFASTINT (end
, ZV
);
4429 Flength (res
); /* Check basic validity of return value */
4430 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
4434 /* Now do the same for annotation functions implied by the file-format */
4435 if (auto_saving
&& (!EQ (Vauto_save_file_format
, Qt
)))
4436 p
= Vauto_save_file_format
;
4438 p
= current_buffer
->file_format
;
4441 struct buffer
*given_buffer
= current_buffer
;
4442 Vwrite_region_annotations_so_far
= annotations
;
4443 res
= call4 (Qformat_annotate_function
, Fcar (p
), start
, end
,
4445 if (current_buffer
!= given_buffer
)
4447 XSETFASTINT (start
, BEGV
);
4448 XSETFASTINT (end
, ZV
);
4452 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
4456 /* At last, do the same for the function PRE_WRITE_CONVERSION
4457 implied by the current coding-system. */
4458 if (!NILP (pre_write_conversion
))
4460 struct buffer
*given_buffer
= current_buffer
;
4461 Vwrite_region_annotations_so_far
= annotations
;
4462 res
= call2 (pre_write_conversion
, start
, end
);
4464 annotations
= (current_buffer
!= given_buffer
4466 : merge (annotations
, res
, Qcar_less_than_car
));
4473 /* Write to descriptor DESC the NBYTES bytes starting at ADDR,
4474 assuming they start at byte position BYTEPOS in the buffer.
4475 Intersperse with them the annotations from *ANNOT
4476 which fall within the range of byte positions BYTEPOS to BYTEPOS + NBYTES,
4477 each at its appropriate position.
4479 We modify *ANNOT by discarding elements as we use them up.
4481 The return value is negative in case of system call failure. */
4484 a_write (desc
, addr
, nbytes
, bytepos
, annot
, coding
)
4486 register char *addr
;
4487 register int nbytes
;
4490 struct coding_system
*coding
;
4494 int lastpos
= bytepos
+ nbytes
;
4496 while (NILP (*annot
) || CONSP (*annot
))
4498 tem
= Fcar_safe (Fcar (*annot
));
4499 nextpos
= bytepos
- 1;
4501 nextpos
= CHAR_TO_BYTE (XFASTINT (tem
));
4503 /* If there are no more annotations in this range,
4504 output the rest of the range all at once. */
4505 if (! (nextpos
>= bytepos
&& nextpos
<= lastpos
))
4506 return e_write (desc
, addr
, lastpos
- bytepos
, coding
);
4508 /* Output buffer text up to the next annotation's position. */
4509 if (nextpos
> bytepos
)
4511 if (0 > e_write (desc
, addr
, nextpos
- bytepos
, coding
))
4513 addr
+= nextpos
- bytepos
;
4516 /* Output the annotation. */
4517 tem
= Fcdr (Fcar (*annot
));
4520 if (0 > e_write (desc
, XSTRING (tem
)->data
, STRING_BYTES (XSTRING (tem
)),
4524 *annot
= Fcdr (*annot
);
4528 #ifndef WRITE_BUF_SIZE
4529 #define WRITE_BUF_SIZE (16 * 1024)
4532 /* Write NBYTES bytes starting at ADDR into descriptor DESC,
4533 encoding them with coding system CODING. */
4536 e_write (desc
, addr
, nbytes
, coding
)
4538 register char *addr
;
4539 register int nbytes
;
4540 struct coding_system
*coding
;
4542 char buf
[WRITE_BUF_SIZE
];
4544 /* We used to have a code for handling selective display here. But,
4545 now it is handled within encode_coding. */
4548 encode_coding (coding
, addr
, buf
, nbytes
, WRITE_BUF_SIZE
);
4549 nbytes
-= coding
->consumed
, addr
+= coding
->consumed
;
4550 if (coding
->produced
> 0)
4552 coding
->produced
-= write (desc
, buf
, coding
->produced
);
4553 if (coding
->produced
) return -1;
4561 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime
,
4562 Sverify_visited_file_modtime
, 1, 1, 0,
4563 "Return t if last mod time of BUF's visited file matches what BUF records.\n\
4564 This means that the file has not been changed since it was visited or saved.")
4570 Lisp_Object handler
;
4571 Lisp_Object filename
;
4573 CHECK_BUFFER (buf
, 0);
4576 if (!STRINGP (b
->filename
)) return Qt
;
4577 if (b
->modtime
== 0) return Qt
;
4579 /* If the file name has special constructs in it,
4580 call the corresponding file handler. */
4581 handler
= Ffind_file_name_handler (b
->filename
,
4582 Qverify_visited_file_modtime
);
4583 if (!NILP (handler
))
4584 return call2 (handler
, Qverify_visited_file_modtime
, buf
);
4586 filename
= ENCODE_FILE (b
->filename
);
4588 if (stat (XSTRING (filename
)->data
, &st
) < 0)
4590 /* If the file doesn't exist now and didn't exist before,
4591 we say that it isn't modified, provided the error is a tame one. */
4592 if (errno
== ENOENT
|| errno
== EACCES
|| errno
== ENOTDIR
)
4597 if (st
.st_mtime
== b
->modtime
4598 /* If both are positive, accept them if they are off by one second. */
4599 || (st
.st_mtime
> 0 && b
->modtime
> 0
4600 && (st
.st_mtime
== b
->modtime
+ 1
4601 || st
.st_mtime
== b
->modtime
- 1)))
4606 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime
,
4607 Sclear_visited_file_modtime
, 0, 0, 0,
4608 "Clear out records of last mod time of visited file.\n\
4609 Next attempt to save will certainly not complain of a discrepancy.")
4612 current_buffer
->modtime
= 0;
4616 DEFUN ("visited-file-modtime", Fvisited_file_modtime
,
4617 Svisited_file_modtime
, 0, 0, 0,
4618 "Return the current buffer's recorded visited file modification time.\n\
4619 The value is a list of the form (HIGH . LOW), like the time values\n\
4620 that `file-attributes' returns.")
4623 return long_to_cons ((unsigned long) current_buffer
->modtime
);
4626 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime
,
4627 Sset_visited_file_modtime
, 0, 1, 0,
4628 "Update buffer's recorded modification time from the visited file's time.\n\
4629 Useful if the buffer was not read from the file normally\n\
4630 or if the file itself has been changed for some known benign reason.\n\
4631 An argument specifies the modification time value to use\n\
4632 \(instead of that of the visited file), in the form of a list\n\
4633 \(HIGH . LOW) or (HIGH LOW).")
4635 Lisp_Object time_list
;
4637 if (!NILP (time_list
))
4638 current_buffer
->modtime
= cons_to_long (time_list
);
4641 register Lisp_Object filename
;
4643 Lisp_Object handler
;
4645 filename
= Fexpand_file_name (current_buffer
->filename
, Qnil
);
4647 /* If the file name has special constructs in it,
4648 call the corresponding file handler. */
4649 handler
= Ffind_file_name_handler (filename
, Qset_visited_file_modtime
);
4650 if (!NILP (handler
))
4651 /* The handler can find the file name the same way we did. */
4652 return call2 (handler
, Qset_visited_file_modtime
, Qnil
);
4654 filename
= ENCODE_FILE (filename
);
4656 if (stat (XSTRING (filename
)->data
, &st
) >= 0)
4657 current_buffer
->modtime
= st
.st_mtime
;
4667 message_with_string ("Autosaving...error for %s", current_buffer
->name
, 1);
4668 Fsleep_for (make_number (1), Qnil
);
4669 message_with_string ("Autosaving...error for %s", current_buffer
->name
, 0);
4670 Fsleep_for (make_number (1), Qnil
);
4671 message_with_string ("Autosaving...error for %s", current_buffer
->name
, 0);
4672 Fsleep_for (make_number (1), Qnil
);
4682 /* Get visited file's mode to become the auto save file's mode. */
4683 if (stat (XSTRING (current_buffer
->filename
)->data
, &st
) >= 0)
4684 /* But make sure we can overwrite it later! */
4685 auto_save_mode_bits
= st
.st_mode
| 0600;
4687 auto_save_mode_bits
= 0666;
4690 Fwrite_region (Qnil
, Qnil
,
4691 current_buffer
->auto_save_file_name
,
4692 Qnil
, Qlambda
, Qnil
, Qnil
);
4696 do_auto_save_unwind (stream
) /* used as unwind-protect function */
4701 fclose ((FILE *) (XFASTINT (XCONS (stream
)->car
) << 16
4702 | XFASTINT (XCONS (stream
)->cdr
)));
4707 do_auto_save_unwind_1 (value
) /* used as unwind-protect function */
4710 minibuffer_auto_raise
= XINT (value
);
4714 DEFUN ("do-auto-save", Fdo_auto_save
, Sdo_auto_save
, 0, 2, "",
4715 "Auto-save all buffers that need it.\n\
4716 This is all buffers that have auto-saving enabled\n\
4717 and are changed since last auto-saved.\n\
4718 Auto-saving writes the buffer into a file\n\
4719 so that your editing is not lost if the system crashes.\n\
4720 This file is not the file you visited; that changes only when you save.\n\
4721 Normally we run the normal hook `auto-save-hook' before saving.\n\n\
4722 A non-nil NO-MESSAGE argument means do not print any message if successful.\n\
4723 A non-nil CURRENT-ONLY argument means save only current buffer.")
4724 (no_message
, current_only
)
4725 Lisp_Object no_message
, current_only
;
4727 struct buffer
*old
= current_buffer
, *b
;
4728 Lisp_Object tail
, buf
;
4730 char *omessage
= echo_area_glyphs
;
4731 int omessage_length
= echo_area_glyphs_length
;
4732 int oldmultibyte
= message_enable_multibyte
;
4733 int do_handled_files
;
4736 Lisp_Object lispstream
;
4737 int count
= specpdl_ptr
- specpdl
;
4739 int orig_minibuffer_auto_raise
= minibuffer_auto_raise
;
4741 /* Ordinarily don't quit within this function,
4742 but don't make it impossible to quit (in case we get hung in I/O). */
4746 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
4747 point to non-strings reached from Vbuffer_alist. */
4752 if (!NILP (Vrun_hooks
))
4753 call1 (Vrun_hooks
, intern ("auto-save-hook"));
4755 if (STRINGP (Vauto_save_list_file_name
))
4757 Lisp_Object listfile
;
4758 listfile
= Fexpand_file_name (Vauto_save_list_file_name
, Qnil
);
4759 stream
= fopen (XSTRING (listfile
)->data
, "w");
4762 /* Arrange to close that file whether or not we get an error.
4763 Also reset auto_saving to 0. */
4764 lispstream
= Fcons (Qnil
, Qnil
);
4765 XSETFASTINT (XCONS (lispstream
)->car
, (EMACS_UINT
)stream
>> 16);
4766 XSETFASTINT (XCONS (lispstream
)->cdr
, (EMACS_UINT
)stream
& 0xffff);
4777 record_unwind_protect (do_auto_save_unwind
, lispstream
);
4778 record_unwind_protect (do_auto_save_unwind_1
,
4779 make_number (minibuffer_auto_raise
));
4780 minibuffer_auto_raise
= 0;
4783 /* First, save all files which don't have handlers. If Emacs is
4784 crashing, the handlers may tweak what is causing Emacs to crash
4785 in the first place, and it would be a shame if Emacs failed to
4786 autosave perfectly ordinary files because it couldn't handle some
4788 for (do_handled_files
= 0; do_handled_files
< 2; do_handled_files
++)
4789 for (tail
= Vbuffer_alist
; GC_CONSP (tail
); tail
= XCONS (tail
)->cdr
)
4791 buf
= XCONS (XCONS (tail
)->car
)->cdr
;
4794 /* Record all the buffers that have auto save mode
4795 in the special file that lists them. For each of these buffers,
4796 Record visited name (if any) and auto save name. */
4797 if (STRINGP (b
->auto_save_file_name
)
4798 && stream
!= NULL
&& do_handled_files
== 0)
4800 if (!NILP (b
->filename
))
4802 fwrite (XSTRING (b
->filename
)->data
, 1,
4803 STRING_BYTES (XSTRING (b
->filename
)), stream
);
4805 putc ('\n', stream
);
4806 fwrite (XSTRING (b
->auto_save_file_name
)->data
, 1,
4807 STRING_BYTES (XSTRING (b
->auto_save_file_name
)), stream
);
4808 putc ('\n', stream
);
4811 if (!NILP (current_only
)
4812 && b
!= current_buffer
)
4815 /* Don't auto-save indirect buffers.
4816 The base buffer takes care of it. */
4820 /* Check for auto save enabled
4821 and file changed since last auto save
4822 and file changed since last real save. */
4823 if (STRINGP (b
->auto_save_file_name
)
4824 && BUF_SAVE_MODIFF (b
) < BUF_MODIFF (b
)
4825 && b
->auto_save_modified
< BUF_MODIFF (b
)
4826 /* -1 means we've turned off autosaving for a while--see below. */
4827 && XINT (b
->save_length
) >= 0
4828 && (do_handled_files
4829 || NILP (Ffind_file_name_handler (b
->auto_save_file_name
,
4832 EMACS_TIME before_time
, after_time
;
4834 EMACS_GET_TIME (before_time
);
4836 /* If we had a failure, don't try again for 20 minutes. */
4837 if (b
->auto_save_failure_time
>= 0
4838 && EMACS_SECS (before_time
) - b
->auto_save_failure_time
< 1200)
4841 if ((XFASTINT (b
->save_length
) * 10
4842 > (BUF_Z (b
) - BUF_BEG (b
)) * 13)
4843 /* A short file is likely to change a large fraction;
4844 spare the user annoying messages. */
4845 && XFASTINT (b
->save_length
) > 5000
4846 /* These messages are frequent and annoying for `*mail*'. */
4847 && !EQ (b
->filename
, Qnil
)
4848 && NILP (no_message
))
4850 /* It has shrunk too much; turn off auto-saving here. */
4851 minibuffer_auto_raise
= orig_minibuffer_auto_raise
;
4852 message_with_string ("Buffer %s has shrunk a lot; auto save turned off there",
4854 minibuffer_auto_raise
= 0;
4855 /* Turn off auto-saving until there's a real save,
4856 and prevent any more warnings. */
4857 XSETINT (b
->save_length
, -1);
4858 Fsleep_for (make_number (1), Qnil
);
4861 set_buffer_internal (b
);
4862 if (!auto_saved
&& NILP (no_message
))
4863 message1 ("Auto-saving...");
4864 internal_condition_case (auto_save_1
, Qt
, auto_save_error
);
4866 b
->auto_save_modified
= BUF_MODIFF (b
);
4867 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4868 set_buffer_internal (old
);
4870 EMACS_GET_TIME (after_time
);
4872 /* If auto-save took more than 60 seconds,
4873 assume it was an NFS failure that got a timeout. */
4874 if (EMACS_SECS (after_time
) - EMACS_SECS (before_time
) > 60)
4875 b
->auto_save_failure_time
= EMACS_SECS (after_time
);
4879 /* Prevent another auto save till enough input events come in. */
4880 record_auto_save ();
4882 if (auto_saved
&& NILP (no_message
))
4886 sit_for (1, 0, 0, 0, 0);
4887 message2 (omessage
, omessage_length
, oldmultibyte
);
4890 message1 ("Auto-saving...done");
4895 unbind_to (count
, Qnil
);
4899 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved
,
4900 Sset_buffer_auto_saved
, 0, 0, 0,
4901 "Mark current buffer as auto-saved with its current text.\n\
4902 No auto-save file will be written until the buffer changes again.")
4905 current_buffer
->auto_save_modified
= MODIFF
;
4906 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4907 current_buffer
->auto_save_failure_time
= -1;
4911 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure
,
4912 Sclear_buffer_auto_save_failure
, 0, 0, 0,
4913 "Clear any record of a recent auto-save failure in the current buffer.")
4916 current_buffer
->auto_save_failure_time
= -1;
4920 DEFUN ("recent-auto-save-p", Frecent_auto_save_p
, Srecent_auto_save_p
,
4922 "Return t if buffer has been auto-saved since last read in or saved.")
4925 return (SAVE_MODIFF
< current_buffer
->auto_save_modified
) ? Qt
: Qnil
;
4928 /* Reading and completing file names */
4929 extern Lisp_Object
Ffile_name_completion (), Ffile_name_all_completions ();
4931 /* In the string VAL, change each $ to $$ and return the result. */
4934 double_dollars (val
)
4937 register unsigned char *old
, *new;
4941 osize
= STRING_BYTES (XSTRING (val
));
4943 /* Count the number of $ characters. */
4944 for (n
= osize
, count
= 0, old
= XSTRING (val
)->data
; n
> 0; n
--)
4945 if (*old
++ == '$') count
++;
4948 old
= XSTRING (val
)->data
;
4949 val
= make_uninit_multibyte_string (XSTRING (val
)->size
+ count
,
4951 new = XSTRING (val
)->data
;
4952 for (n
= osize
; n
> 0; n
--)
4965 DEFUN ("read-file-name-internal", Fread_file_name_internal
, Sread_file_name_internal
,
4967 "Internal subroutine for read-file-name. Do not call this.")
4968 (string
, dir
, action
)
4969 Lisp_Object string
, dir
, action
;
4970 /* action is nil for complete, t for return list of completions,
4971 lambda for verify final value */
4973 Lisp_Object name
, specdir
, realdir
, val
, orig_string
;
4975 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
4977 CHECK_STRING (string
, 0);
4984 /* No need to protect ACTION--we only compare it with t and nil. */
4985 GCPRO5 (string
, realdir
, name
, specdir
, orig_string
);
4987 if (XSTRING (string
)->size
== 0)
4989 if (EQ (action
, Qlambda
))
4997 orig_string
= string
;
4998 string
= Fsubstitute_in_file_name (string
);
4999 changed
= NILP (Fstring_equal (string
, orig_string
));
5000 name
= Ffile_name_nondirectory (string
);
5001 val
= Ffile_name_directory (string
);
5003 realdir
= Fexpand_file_name (val
, realdir
);
5008 specdir
= Ffile_name_directory (string
);
5009 val
= Ffile_name_completion (name
, realdir
);
5014 return double_dollars (string
);
5018 if (!NILP (specdir
))
5019 val
= concat2 (specdir
, val
);
5021 return double_dollars (val
);
5024 #endif /* not VMS */
5028 if (EQ (action
, Qt
))
5029 return Ffile_name_all_completions (name
, realdir
);
5030 /* Only other case actually used is ACTION = lambda */
5032 /* Supposedly this helps commands such as `cd' that read directory names,
5033 but can someone explain how it helps them? -- RMS */
5034 if (XSTRING (name
)->size
== 0)
5037 return Ffile_exists_p (string
);
5040 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
5041 "Read file name, prompting with PROMPT and completing in directory DIR.\n\
5042 Value is not expanded---you must call `expand-file-name' yourself.\n\
5043 Default name to DEFAULT-FILENAME if user enters a null string.\n\
5044 (If DEFAULT-FILENAME is omitted, the visited file name is used,\n\
5045 except that if INITIAL is specified, that combined with DIR is used.)\n\
5046 Fourth arg MUSTMATCH non-nil means require existing file's name.\n\
5047 Non-nil and non-t means also require confirmation after completion.\n\
5048 Fifth arg INITIAL specifies text to start with.\n\
5049 DIR defaults to current buffer's directory default.")
5050 (prompt
, dir
, default_filename
, mustmatch
, initial
)
5051 Lisp_Object prompt
, dir
, default_filename
, mustmatch
, initial
;
5053 Lisp_Object val
, insdef
, insdef1
, tem
;
5054 struct gcpro gcpro1
, gcpro2
;
5055 register char *homedir
;
5056 int replace_in_history
= 0;
5057 int add_to_history
= 0;
5061 dir
= current_buffer
->directory
;
5062 if (NILP (default_filename
))
5064 if (! NILP (initial
))
5065 default_filename
= Fexpand_file_name (initial
, dir
);
5067 default_filename
= current_buffer
->filename
;
5070 /* If dir starts with user's homedir, change that to ~. */
5071 homedir
= (char *) egetenv ("HOME");
5073 homedir
= strcpy (alloca (strlen (homedir
) + 1), homedir
);
5074 CORRECT_DIR_SEPS (homedir
);
5078 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
5079 && IS_DIRECTORY_SEP (XSTRING (dir
)->data
[strlen (homedir
)]))
5081 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
5082 STRING_BYTES (XSTRING (dir
)) - strlen (homedir
) + 1);
5083 XSTRING (dir
)->data
[0] = '~';
5086 if (insert_default_directory
&& STRINGP (dir
))
5089 if (!NILP (initial
))
5091 Lisp_Object args
[2], pos
;
5095 insdef
= Fconcat (2, args
);
5096 pos
= make_number (XSTRING (double_dollars (dir
))->size
);
5097 insdef1
= Fcons (double_dollars (insdef
), pos
);
5100 insdef1
= double_dollars (insdef
);
5102 else if (STRINGP (initial
))
5105 insdef1
= Fcons (double_dollars (insdef
), make_number (0));
5108 insdef
= Qnil
, insdef1
= Qnil
;
5111 count
= specpdl_ptr
- specpdl
;
5112 specbind (intern ("completion-ignore-case"), Qt
);
5115 GCPRO2 (insdef
, default_filename
);
5116 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
5117 dir
, mustmatch
, insdef1
,
5118 Qfile_name_history
, default_filename
, Qnil
);
5120 tem
= Fsymbol_value (Qfile_name_history
);
5121 if (CONSP (tem
) && EQ (XCONS (tem
)->car
, val
))
5122 replace_in_history
= 1;
5124 /* If Fcompleting_read returned the inserted default string itself
5125 (rather than a new string with the same contents),
5126 it has to mean that the user typed RET with the minibuffer empty.
5127 In that case, we really want to return ""
5128 so that commands such as set-visited-file-name can distinguish. */
5129 if (EQ (val
, default_filename
))
5131 /* In this case, Fcompleting_read has not added an element
5132 to the history. Maybe we should. */
5133 if (! replace_in_history
)
5136 val
= build_string ("");
5140 unbind_to (count
, Qnil
);
5145 error ("No file name specified");
5147 tem
= Fstring_equal (val
, insdef
);
5149 if (!NILP (tem
) && !NILP (default_filename
))
5150 val
= default_filename
;
5151 else if (XSTRING (val
)->size
== 0 && NILP (insdef
))
5153 if (!NILP (default_filename
))
5154 val
= default_filename
;
5156 error ("No default file name");
5158 val
= Fsubstitute_in_file_name (val
);
5160 if (replace_in_history
)
5161 /* Replace what Fcompleting_read added to the history
5162 with what we will actually return. */
5163 XCONS (Fsymbol_value (Qfile_name_history
))->car
= val
;
5164 else if (add_to_history
)
5166 /* Add the value to the history--but not if it matches
5167 the last value already there. */
5168 tem
= Fsymbol_value (Qfile_name_history
);
5169 if (! CONSP (tem
) || NILP (Fequal (XCONS (tem
)->car
, val
)))
5170 Fset (Qfile_name_history
,
5178 Qexpand_file_name
= intern ("expand-file-name");
5179 Qsubstitute_in_file_name
= intern ("substitute-in-file-name");
5180 Qdirectory_file_name
= intern ("directory-file-name");
5181 Qfile_name_directory
= intern ("file-name-directory");
5182 Qfile_name_nondirectory
= intern ("file-name-nondirectory");
5183 Qunhandled_file_name_directory
= intern ("unhandled-file-name-directory");
5184 Qfile_name_as_directory
= intern ("file-name-as-directory");
5185 Qcopy_file
= intern ("copy-file");
5186 Qmake_directory_internal
= intern ("make-directory-internal");
5187 Qdelete_directory
= intern ("delete-directory");
5188 Qdelete_file
= intern ("delete-file");
5189 Qrename_file
= intern ("rename-file");
5190 Qadd_name_to_file
= intern ("add-name-to-file");
5191 Qmake_symbolic_link
= intern ("make-symbolic-link");
5192 Qfile_exists_p
= intern ("file-exists-p");
5193 Qfile_executable_p
= intern ("file-executable-p");
5194 Qfile_readable_p
= intern ("file-readable-p");
5195 Qfile_writable_p
= intern ("file-writable-p");
5196 Qfile_symlink_p
= intern ("file-symlink-p");
5197 Qaccess_file
= intern ("access-file");
5198 Qfile_directory_p
= intern ("file-directory-p");
5199 Qfile_regular_p
= intern ("file-regular-p");
5200 Qfile_accessible_directory_p
= intern ("file-accessible-directory-p");
5201 Qfile_modes
= intern ("file-modes");
5202 Qset_file_modes
= intern ("set-file-modes");
5203 Qfile_newer_than_file_p
= intern ("file-newer-than-file-p");
5204 Qinsert_file_contents
= intern ("insert-file-contents");
5205 Qwrite_region
= intern ("write-region");
5206 Qverify_visited_file_modtime
= intern ("verify-visited-file-modtime");
5207 Qset_visited_file_modtime
= intern ("set-visited-file-modtime");
5209 staticpro (&Qexpand_file_name
);
5210 staticpro (&Qsubstitute_in_file_name
);
5211 staticpro (&Qdirectory_file_name
);
5212 staticpro (&Qfile_name_directory
);
5213 staticpro (&Qfile_name_nondirectory
);
5214 staticpro (&Qunhandled_file_name_directory
);
5215 staticpro (&Qfile_name_as_directory
);
5216 staticpro (&Qcopy_file
);
5217 staticpro (&Qmake_directory_internal
);
5218 staticpro (&Qdelete_directory
);
5219 staticpro (&Qdelete_file
);
5220 staticpro (&Qrename_file
);
5221 staticpro (&Qadd_name_to_file
);
5222 staticpro (&Qmake_symbolic_link
);
5223 staticpro (&Qfile_exists_p
);
5224 staticpro (&Qfile_executable_p
);
5225 staticpro (&Qfile_readable_p
);
5226 staticpro (&Qfile_writable_p
);
5227 staticpro (&Qaccess_file
);
5228 staticpro (&Qfile_symlink_p
);
5229 staticpro (&Qfile_directory_p
);
5230 staticpro (&Qfile_regular_p
);
5231 staticpro (&Qfile_accessible_directory_p
);
5232 staticpro (&Qfile_modes
);
5233 staticpro (&Qset_file_modes
);
5234 staticpro (&Qfile_newer_than_file_p
);
5235 staticpro (&Qinsert_file_contents
);
5236 staticpro (&Qwrite_region
);
5237 staticpro (&Qverify_visited_file_modtime
);
5238 staticpro (&Qset_visited_file_modtime
);
5240 Qfile_name_history
= intern ("file-name-history");
5241 Fset (Qfile_name_history
, Qnil
);
5242 staticpro (&Qfile_name_history
);
5244 Qfile_error
= intern ("file-error");
5245 staticpro (&Qfile_error
);
5246 Qfile_already_exists
= intern ("file-already-exists");
5247 staticpro (&Qfile_already_exists
);
5248 Qfile_date_error
= intern ("file-date-error");
5249 staticpro (&Qfile_date_error
);
5252 Qfind_buffer_file_type
= intern ("find-buffer-file-type");
5253 staticpro (&Qfind_buffer_file_type
);
5256 DEFVAR_LISP ("file-name-coding-system", &Vfile_name_coding_system
,
5257 "*Coding system for encoding file names.\n\
5258 If it is nil, default-file-name-coding-system (which see) is used.");
5259 Vfile_name_coding_system
= Qnil
;
5261 DEFVAR_LISP ("default-file-name-coding-system",
5262 &Vdefault_file_name_coding_system
,
5263 "Default coding system for encoding file names.\n\
5264 This variable is used only when file-name-coding-system is nil.\n\
5266 This variable is set/changed by the command set-language-environment.\n\
5267 User should not set this variable manually,\n\
5268 instead use file-name-coding-system to get a constant encoding\n\
5269 of file names regardless of the current language environment.");
5270 Vdefault_file_name_coding_system
= Qnil
;
5272 DEFVAR_LISP ("auto-save-file-format", &Vauto_save_file_format
,
5273 "*Format in which to write auto-save files.\n\
5274 Should be a list of symbols naming formats that are defined in `format-alist'.\n\
5275 If it is t, which is the default, auto-save files are written in the\n\
5276 same format as a regular save would use.");
5277 Vauto_save_file_format
= Qt
;
5279 Qformat_decode
= intern ("format-decode");
5280 staticpro (&Qformat_decode
);
5281 Qformat_annotate_function
= intern ("format-annotate-function");
5282 staticpro (&Qformat_annotate_function
);
5284 Qcar_less_than_car
= intern ("car-less-than-car");
5285 staticpro (&Qcar_less_than_car
);
5287 Fput (Qfile_error
, Qerror_conditions
,
5288 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
)));
5289 Fput (Qfile_error
, Qerror_message
,
5290 build_string ("File error"));
5292 Fput (Qfile_already_exists
, Qerror_conditions
,
5293 Fcons (Qfile_already_exists
,
5294 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
5295 Fput (Qfile_already_exists
, Qerror_message
,
5296 build_string ("File already exists"));
5298 Fput (Qfile_date_error
, Qerror_conditions
,
5299 Fcons (Qfile_date_error
,
5300 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
5301 Fput (Qfile_date_error
, Qerror_message
,
5302 build_string ("Cannot set file date"));
5304 DEFVAR_BOOL ("insert-default-directory", &insert_default_directory
,
5305 "*Non-nil means when reading a filename start with default dir in minibuffer.");
5306 insert_default_directory
= 1;
5308 DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm
,
5309 "*Non-nil means write new files with record format `stmlf'.\n\
5310 nil means use format `var'. This variable is meaningful only on VMS.");
5311 vms_stmlf_recfm
= 0;
5313 DEFVAR_LISP ("directory-sep-char", &Vdirectory_sep_char
,
5314 "Directory separator character for built-in functions that return file names.\n\
5315 The value should be either ?/ or ?\\ (any other value is treated as ?\\).\n\
5316 This variable affects the built-in functions only on Windows,\n\
5317 on other platforms, it is initialized so that Lisp code can find out\n\
5318 what the normal separator is.");
5319 XSETFASTINT (Vdirectory_sep_char
, '/');
5321 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist
,
5322 "*Alist of elements (REGEXP . HANDLER) for file names handled specially.\n\
5323 If a file name matches REGEXP, then all I/O on that file is done by calling\n\
5326 The first argument given to HANDLER is the name of the I/O primitive\n\
5327 to be handled; the remaining arguments are the arguments that were\n\
5328 passed to that primitive. For example, if you do\n\
5329 (file-exists-p FILENAME)\n\
5330 and FILENAME is handled by HANDLER, then HANDLER is called like this:\n\
5331 (funcall HANDLER 'file-exists-p FILENAME)\n\
5332 The function `find-file-name-handler' checks this list for a handler\n\
5333 for its argument.");
5334 Vfile_name_handler_alist
= Qnil
;
5336 DEFVAR_LISP ("set-auto-coding-function",
5337 &Vset_auto_coding_function
,
5338 "If non-nil, a function to call to decide a coding system of file.\n\
5339 One argument is passed to this function: the string of concatination\n\
5340 or the heading 1K-byte and the tailing 3K-byte of a file to be read.\n\
5341 This function should return a coding system to decode the file contents\n\
5342 specified in the heading lines with the format:\n\
5343 -*- ... coding: CODING-SYSTEM; ... -*-\n\
5344 or local variable spec of the tailing lines with `coding:' tag.");
5345 Vset_auto_coding_function
= Qnil
;
5347 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions
,
5348 "A list of functions to be called at the end of `insert-file-contents'.\n\
5349 Each is passed one argument, the number of bytes inserted. It should return\n\
5350 the new byte count, and leave point the same. If `insert-file-contents' is\n\
5351 intercepted by a handler from `file-name-handler-alist', that handler is\n\
5352 responsible for calling the after-insert-file-functions if appropriate.");
5353 Vafter_insert_file_functions
= Qnil
;
5355 DEFVAR_LISP ("write-region-annotate-functions", &Vwrite_region_annotate_functions
,
5356 "A list of functions to be called at the start of `write-region'.\n\
5357 Each is passed two arguments, START and END as for `write-region'.\n\
5358 These are usually two numbers but not always; see the documentation\n\
5359 for `write-region'. The function should return a list of pairs\n\
5360 of the form (POSITION . STRING), consisting of strings to be effectively\n\
5361 inserted at the specified positions of the file being written (1 means to\n\
5362 insert before the first byte written). The POSITIONs must be sorted into\n\
5363 increasing order. If there are several functions in the list, the several\n\
5364 lists are merged destructively.");
5365 Vwrite_region_annotate_functions
= Qnil
;
5367 DEFVAR_LISP ("write-region-annotations-so-far",
5368 &Vwrite_region_annotations_so_far
,
5369 "When an annotation function is called, this holds the previous annotations.\n\
5370 These are the annotations made by other annotation functions\n\
5371 that were already called. See also `write-region-annotate-functions'.");
5372 Vwrite_region_annotations_so_far
= Qnil
;
5374 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers
,
5375 "A list of file name handlers that temporarily should not be used.\n\
5376 This applies only to the operation `inhibit-file-name-operation'.");
5377 Vinhibit_file_name_handlers
= Qnil
;
5379 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation
,
5380 "The operation for which `inhibit-file-name-handlers' is applicable.");
5381 Vinhibit_file_name_operation
= Qnil
;
5383 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name
,
5384 "File name in which we write a list of all auto save file names.\n\
5385 This variable is initialized automatically from `auto-save-list-file-prefix'\n\
5386 shortly after Emacs reads your `.emacs' file, if you have not yet given it\n\
5388 Vauto_save_list_file_name
= Qnil
;
5390 defsubr (&Sfind_file_name_handler
);
5391 defsubr (&Sfile_name_directory
);
5392 defsubr (&Sfile_name_nondirectory
);
5393 defsubr (&Sunhandled_file_name_directory
);
5394 defsubr (&Sfile_name_as_directory
);
5395 defsubr (&Sdirectory_file_name
);
5396 defsubr (&Smake_temp_name
);
5397 defsubr (&Sexpand_file_name
);
5398 defsubr (&Ssubstitute_in_file_name
);
5399 defsubr (&Scopy_file
);
5400 defsubr (&Smake_directory_internal
);
5401 defsubr (&Sdelete_directory
);
5402 defsubr (&Sdelete_file
);
5403 defsubr (&Srename_file
);
5404 defsubr (&Sadd_name_to_file
);
5406 defsubr (&Smake_symbolic_link
);
5407 #endif /* S_IFLNK */
5409 defsubr (&Sdefine_logical_name
);
5412 defsubr (&Ssysnetunam
);
5413 #endif /* HPUX_NET */
5414 defsubr (&Sfile_name_absolute_p
);
5415 defsubr (&Sfile_exists_p
);
5416 defsubr (&Sfile_executable_p
);
5417 defsubr (&Sfile_readable_p
);
5418 defsubr (&Sfile_writable_p
);
5419 defsubr (&Saccess_file
);
5420 defsubr (&Sfile_symlink_p
);
5421 defsubr (&Sfile_directory_p
);
5422 defsubr (&Sfile_accessible_directory_p
);
5423 defsubr (&Sfile_regular_p
);
5424 defsubr (&Sfile_modes
);
5425 defsubr (&Sset_file_modes
);
5426 defsubr (&Sset_default_file_modes
);
5427 defsubr (&Sdefault_file_modes
);
5428 defsubr (&Sfile_newer_than_file_p
);
5429 defsubr (&Sinsert_file_contents
);
5430 defsubr (&Swrite_region
);
5431 defsubr (&Scar_less_than_car
);
5432 defsubr (&Sverify_visited_file_modtime
);
5433 defsubr (&Sclear_visited_file_modtime
);
5434 defsubr (&Svisited_file_modtime
);
5435 defsubr (&Sset_visited_file_modtime
);
5436 defsubr (&Sdo_auto_save
);
5437 defsubr (&Sset_buffer_auto_saved
);
5438 defsubr (&Sclear_buffer_auto_save_failure
);
5439 defsubr (&Srecent_auto_save_p
);
5441 defsubr (&Sread_file_name_internal
);
5442 defsubr (&Sread_file_name
);
5445 defsubr (&Sunix_sync
);