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.")
803 /* Don't use too many characters of the restricted 8+3 DOS
805 val
= concat2 (prefix
, build_string ("a.XXX"));
807 val
= concat2 (prefix
, build_string ("XXXXXX"));
809 temp
= mktemp (XSTRING (val
)->data
);
811 error ("No temporary file names based on %s are available",
812 XSTRING (prefix
)->data
);
814 CORRECT_DIR_SEPS (XSTRING (val
)->data
);
819 DEFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
820 "Convert filename NAME to absolute, and canonicalize it.\n\
821 Second arg DEFAULT-DIRECTORY is directory to start with if NAME is relative\n\
822 (does not start with slash); if DEFAULT-DIRECTORY is nil or missing,\n\
823 the current buffer's value of default-directory is used.\n\
824 File name components that are `.' are removed, and \n\
825 so are file name components followed by `..', along with the `..' itself;\n\
826 note that these simplifications are done without checking the resulting\n\
827 file names in the file system.\n\
828 An initial `~/' expands to your home directory.\n\
829 An initial `~USER/' expands to USER's home directory.\n\
830 See also the function `substitute-in-file-name'.")
831 (name
, default_directory
)
832 Lisp_Object name
, default_directory
;
836 register unsigned char *newdir
, *p
, *o
;
838 unsigned char *target
;
841 unsigned char * colon
= 0;
842 unsigned char * close
= 0;
843 unsigned char * slash
= 0;
844 unsigned char * brack
= 0;
845 int lbrack
= 0, rbrack
= 0;
850 int collapse_newdir
= 1;
855 CHECK_STRING (name
, 0);
857 /* If the file name has special constructs in it,
858 call the corresponding file handler. */
859 handler
= Ffind_file_name_handler (name
, Qexpand_file_name
);
861 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
863 /* Use the buffer's default-directory if DEFAULT_DIRECTORY is omitted. */
864 if (NILP (default_directory
))
865 default_directory
= current_buffer
->directory
;
866 if (! STRINGP (default_directory
))
867 default_directory
= build_string ("/");
869 if (!NILP (default_directory
))
871 handler
= Ffind_file_name_handler (default_directory
, Qexpand_file_name
);
873 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
876 o
= XSTRING (default_directory
)->data
;
878 /* Make sure DEFAULT_DIRECTORY is properly expanded.
879 It would be better to do this down below where we actually use
880 default_directory. Unfortunately, calling Fexpand_file_name recursively
881 could invoke GC, and the strings might be relocated. This would
882 be annoying because we have pointers into strings lying around
883 that would need adjusting, and people would add new pointers to
884 the code and forget to adjust them, resulting in intermittent bugs.
885 Putting this call here avoids all that crud.
887 The EQ test avoids infinite recursion. */
888 if (! NILP (default_directory
) && !EQ (default_directory
, name
)
889 /* Save time in some common cases - as long as default_directory
890 is not relative, it can be canonicalized with name below (if it
891 is needed at all) without requiring it to be expanded now. */
893 /* Detect MSDOS file names with drive specifiers. */
894 && ! (IS_DRIVE (o
[0]) && (IS_DEVICE_SEP (o
[1]) && IS_DIRECTORY_SEP (o
[2])))
896 /* Detect Windows file names in UNC format. */
897 && ! (IS_DIRECTORY_SEP (o
[0]) && IS_DIRECTORY_SEP (o
[1]))
899 #else /* not DOS_NT */
900 /* Detect Unix absolute file names (/... alone is not absolute on
902 && ! (IS_DIRECTORY_SEP (o
[0]))
903 #endif /* not DOS_NT */
909 default_directory
= Fexpand_file_name (default_directory
, Qnil
);
914 /* Filenames on VMS are always upper case. */
915 name
= Fupcase (name
);
917 #ifdef FILE_SYSTEM_CASE
918 name
= FILE_SYSTEM_CASE (name
);
921 nm
= XSTRING (name
)->data
;
924 /* We will force directory separators to be either all \ or /, so make
925 a local copy to modify, even if there ends up being no change. */
926 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
928 /* Find and remove drive specifier if present; this makes nm absolute
929 even if the rest of the name appears to be relative. */
931 unsigned char *colon
= rindex (nm
, ':');
934 /* Only recognize colon as part of drive specifier if there is a
935 single alphabetic character preceeding the colon (and if the
936 character before the drive letter, if present, is a directory
937 separator); this is to support the remote system syntax used by
938 ange-ftp, and the "po:username" syntax for POP mailboxes. */
942 else if (IS_DRIVE (colon
[-1])
943 && (colon
== nm
+ 1 || IS_DIRECTORY_SEP (colon
[-2])))
950 while (--colon
>= nm
)
957 /* If we see "c://somedir", we want to strip the first slash after the
958 colon when stripping the drive letter. Otherwise, this expands to
960 if (drive
&& IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
962 #endif /* WINDOWSNT */
966 /* Discard any previous drive specifier if nm is now in UNC format. */
967 if (IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
973 /* If nm is absolute, look for /./ or /../ sequences; if none are
974 found, we can probably return right away. We will avoid allocating
975 a new string if name is already fully expanded. */
977 IS_DIRECTORY_SEP (nm
[0])
982 && (drive
|| IS_DIRECTORY_SEP (nm
[1]))
989 /* If it turns out that the filename we want to return is just a
990 suffix of FILENAME, we don't need to go through and edit
991 things; we just need to construct a new string using data
992 starting at the middle of FILENAME. If we set lose to a
993 non-zero value, that means we've discovered that we can't do
1000 /* Since we know the name is absolute, we can assume that each
1001 element starts with a "/". */
1003 /* "." and ".." are hairy. */
1004 if (IS_DIRECTORY_SEP (p
[0])
1006 && (IS_DIRECTORY_SEP (p
[2])
1008 || (p
[2] == '.' && (IS_DIRECTORY_SEP (p
[3])
1015 /* if dev:[dir]/, move nm to / */
1016 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1017 nm
= (brack
? brack
+ 1 : colon
+ 1);
1018 lbrack
= rbrack
= 0;
1026 /* VMS pre V4.4,convert '-'s in filenames. */
1027 if (lbrack
== rbrack
)
1029 if (dots
< 2) /* this is to allow negative version numbers */
1034 if (lbrack
> rbrack
&&
1035 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1036 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1042 /* count open brackets, reset close bracket pointer */
1043 if (p
[0] == '[' || p
[0] == '<')
1044 lbrack
++, brack
= 0;
1045 /* count close brackets, set close bracket pointer */
1046 if (p
[0] == ']' || p
[0] == '>')
1047 rbrack
++, brack
= p
;
1048 /* detect ][ or >< */
1049 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1051 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1052 nm
= p
+ 1, lose
= 1;
1053 if (p
[0] == ':' && (colon
|| slash
))
1054 /* if dev1:[dir]dev2:, move nm to dev2: */
1060 /* if /name/dev:, move nm to dev: */
1063 /* if node::dev:, move colon following dev */
1064 else if (colon
&& colon
[-1] == ':')
1066 /* if dev1:dev2:, move nm to dev2: */
1067 else if (colon
&& colon
[-1] != ':')
1072 if (p
[0] == ':' && !colon
)
1078 if (lbrack
== rbrack
)
1081 else if (p
[0] == '.')
1089 if (index (nm
, '/'))
1090 return build_string (sys_translate_unix (nm
));
1093 /* Make sure directories are all separated with / or \ as
1094 desired, but avoid allocation of a new string when not
1096 CORRECT_DIR_SEPS (nm
);
1098 if (IS_DIRECTORY_SEP (nm
[1]))
1100 if (strcmp (nm
, XSTRING (name
)->data
) != 0)
1101 name
= build_string (nm
);
1105 /* drive must be set, so this is okay */
1106 if (strcmp (nm
- 2, XSTRING (name
)->data
) != 0)
1108 name
= make_string (nm
- 2, p
- nm
+ 2);
1109 XSTRING (name
)->data
[0] = DRIVE_LETTER (drive
);
1110 XSTRING (name
)->data
[1] = ':';
1113 #else /* not DOS_NT */
1114 if (nm
== XSTRING (name
)->data
)
1116 return build_string (nm
);
1117 #endif /* not DOS_NT */
1121 /* At this point, nm might or might not be an absolute file name. We
1122 need to expand ~ or ~user if present, otherwise prefix nm with
1123 default_directory if nm is not absolute, and finally collapse /./
1124 and /foo/../ sequences.
1126 We set newdir to be the appropriate prefix if one is needed:
1127 - the relevant user directory if nm starts with ~ or ~user
1128 - the specified drive's working dir (DOS/NT only) if nm does not
1130 - the value of default_directory.
1132 Note that these prefixes are not guaranteed to be absolute (except
1133 for the working dir of a drive). Therefore, to ensure we always
1134 return an absolute name, if the final prefix is not absolute we
1135 append it to the current working directory. */
1139 if (nm
[0] == '~') /* prefix ~ */
1141 if (IS_DIRECTORY_SEP (nm
[1])
1145 || nm
[1] == 0) /* ~ by itself */
1147 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1148 newdir
= (unsigned char *) "";
1151 collapse_newdir
= 0;
1154 nm
++; /* Don't leave the slash in nm. */
1157 else /* ~user/filename */
1159 for (p
= nm
; *p
&& (!IS_DIRECTORY_SEP (*p
)
1164 o
= (unsigned char *) alloca (p
- nm
+ 1);
1165 bcopy ((char *) nm
, o
, p
- nm
);
1168 pw
= (struct passwd
*) getpwnam (o
+ 1);
1171 newdir
= (unsigned char *) pw
-> pw_dir
;
1173 nm
= p
+ 1; /* skip the terminator */
1177 collapse_newdir
= 0;
1182 /* If we don't find a user of that name, leave the name
1183 unchanged; don't move nm forward to p. */
1188 /* On DOS and Windows, nm is absolute if a drive name was specified;
1189 use the drive's current directory as the prefix if needed. */
1190 if (!newdir
&& drive
)
1192 /* Get default directory if needed to make nm absolute. */
1193 if (!IS_DIRECTORY_SEP (nm
[0]))
1195 newdir
= alloca (MAXPATHLEN
+ 1);
1196 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1201 /* Either nm starts with /, or drive isn't mounted. */
1202 newdir
= alloca (4);
1203 newdir
[0] = DRIVE_LETTER (drive
);
1211 /* Finally, if no prefix has been specified and nm is not absolute,
1212 then it must be expanded relative to default_directory. */
1216 /* /... alone is not absolute on DOS and Windows. */
1217 && !IS_DIRECTORY_SEP (nm
[0])
1220 && !(IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1227 newdir
= XSTRING (default_directory
)->data
;
1233 /* First ensure newdir is an absolute name. */
1235 /* Detect MSDOS file names with drive specifiers. */
1236 ! (IS_DRIVE (newdir
[0])
1237 && IS_DEVICE_SEP (newdir
[1]) && IS_DIRECTORY_SEP (newdir
[2]))
1239 /* Detect Windows file names in UNC format. */
1240 && ! (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1244 /* Effectively, let newdir be (expand-file-name newdir cwd).
1245 Because of the admonition against calling expand-file-name
1246 when we have pointers into lisp strings, we accomplish this
1247 indirectly by prepending newdir to nm if necessary, and using
1248 cwd (or the wd of newdir's drive) as the new newdir. */
1250 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1255 if (!IS_DIRECTORY_SEP (nm
[0]))
1257 char * tmp
= alloca (strlen (newdir
) + strlen (nm
) + 2);
1258 file_name_as_directory (tmp
, newdir
);
1262 newdir
= alloca (MAXPATHLEN
+ 1);
1265 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1272 /* Strip off drive name from prefix, if present. */
1273 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1279 /* Keep only a prefix from newdir if nm starts with slash
1280 (//server/share for UNC, nothing otherwise). */
1281 if (IS_DIRECTORY_SEP (nm
[0]) && collapse_newdir
)
1284 if (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1286 newdir
= strcpy (alloca (strlen (newdir
) + 1), newdir
);
1288 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1290 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1302 /* Get rid of any slash at the end of newdir, unless newdir is
1303 just // (an incomplete UNC name). */
1304 length
= strlen (newdir
);
1305 if (length
> 0 && IS_DIRECTORY_SEP (newdir
[length
- 1])
1307 && !(length
== 2 && IS_DIRECTORY_SEP (newdir
[0]))
1311 unsigned char *temp
= (unsigned char *) alloca (length
);
1312 bcopy (newdir
, temp
, length
- 1);
1313 temp
[length
- 1] = 0;
1321 /* Now concatenate the directory and name to new space in the stack frame */
1322 tlen
+= strlen (nm
) + 1;
1324 /* Add reserved space for drive name. (The Microsoft x86 compiler
1325 produces incorrect code if the following two lines are combined.) */
1326 target
= (unsigned char *) alloca (tlen
+ 2);
1328 #else /* not DOS_NT */
1329 target
= (unsigned char *) alloca (tlen
);
1330 #endif /* not DOS_NT */
1336 if (nm
[0] == 0 || IS_DIRECTORY_SEP (nm
[0]))
1337 strcpy (target
, newdir
);
1340 file_name_as_directory (target
, newdir
);
1343 strcat (target
, nm
);
1345 if (index (target
, '/'))
1346 strcpy (target
, sys_translate_unix (target
));
1349 /* ASSERT (IS_DIRECTORY_SEP (target[0])) if not VMS */
1351 /* Now canonicalize by removing /. and /foo/.. if they appear. */
1359 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1365 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1366 /* brackets are offset from each other by 2 */
1369 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1370 /* convert [foo][bar] to [bar] */
1371 while (o
[-1] != '[' && o
[-1] != '<')
1373 else if (*p
== '-' && *o
!= '.')
1376 else if (p
[0] == '-' && o
[-1] == '.' &&
1377 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1378 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1382 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1383 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1385 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1387 /* else [foo.-] ==> [-] */
1393 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1394 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1400 if (!IS_DIRECTORY_SEP (*p
))
1404 else if (IS_DIRECTORY_SEP (p
[0])
1406 && (IS_DIRECTORY_SEP (p
[2])
1409 /* If "/." is the entire filename, keep the "/". Otherwise,
1410 just delete the whole "/.". */
1411 if (o
== target
&& p
[2] == '\0')
1415 else if (IS_DIRECTORY_SEP (p
[0]) && p
[1] == '.' && p
[2] == '.'
1416 /* `/../' is the "superroot" on certain file systems. */
1418 && (IS_DIRECTORY_SEP (p
[3]) || p
[3] == 0))
1420 while (o
!= target
&& (--o
) && !IS_DIRECTORY_SEP (*o
))
1422 /* Keep initial / only if this is the whole name. */
1423 if (o
== target
&& IS_ANY_SEP (*o
) && p
[3] == 0)
1431 #endif /* not VMS */
1435 /* At last, set drive name. */
1437 /* Except for network file name. */
1438 if (!(IS_DIRECTORY_SEP (target
[0]) && IS_DIRECTORY_SEP (target
[1])))
1439 #endif /* WINDOWSNT */
1441 if (!drive
) abort ();
1443 target
[0] = DRIVE_LETTER (drive
);
1446 CORRECT_DIR_SEPS (target
);
1449 return make_string (target
, o
- target
);
1453 /* Changed this DEFUN to a DEAFUN, so as not to confuse `make-docfile'. */
1454 DEAFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
1455 "Convert FILENAME to absolute, and canonicalize it.\n\
1456 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
1457 (does not start with slash); if DEFAULT is nil or missing,\n\
1458 the current buffer's value of default-directory is used.\n\
1459 Filenames containing `.' or `..' as components are simplified;\n\
1460 initial `~/' expands to your home directory.\n\
1461 See also the function `substitute-in-file-name'.")
1463 Lisp_Object name
, defalt
;
1467 register unsigned char *newdir
, *p
, *o
;
1469 unsigned char *target
;
1473 unsigned char * colon
= 0;
1474 unsigned char * close
= 0;
1475 unsigned char * slash
= 0;
1476 unsigned char * brack
= 0;
1477 int lbrack
= 0, rbrack
= 0;
1481 CHECK_STRING (name
, 0);
1484 /* Filenames on VMS are always upper case. */
1485 name
= Fupcase (name
);
1488 nm
= XSTRING (name
)->data
;
1490 /* If nm is absolute, flush ...// and detect /./ and /../.
1491 If no /./ or /../ we can return right away. */
1503 if (p
[0] == '/' && p
[1] == '/'
1505 /* // at start of filename is meaningful on Apollo system. */
1510 if (p
[0] == '/' && p
[1] == '~')
1511 nm
= p
+ 1, lose
= 1;
1512 if (p
[0] == '/' && p
[1] == '.'
1513 && (p
[2] == '/' || p
[2] == 0
1514 || (p
[2] == '.' && (p
[3] == '/' || p
[3] == 0))))
1520 /* if dev:[dir]/, move nm to / */
1521 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1522 nm
= (brack
? brack
+ 1 : colon
+ 1);
1523 lbrack
= rbrack
= 0;
1531 /* VMS pre V4.4,convert '-'s in filenames. */
1532 if (lbrack
== rbrack
)
1534 if (dots
< 2) /* this is to allow negative version numbers */
1539 if (lbrack
> rbrack
&&
1540 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1541 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1547 /* count open brackets, reset close bracket pointer */
1548 if (p
[0] == '[' || p
[0] == '<')
1549 lbrack
++, brack
= 0;
1550 /* count close brackets, set close bracket pointer */
1551 if (p
[0] == ']' || p
[0] == '>')
1552 rbrack
++, brack
= p
;
1553 /* detect ][ or >< */
1554 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1556 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1557 nm
= p
+ 1, lose
= 1;
1558 if (p
[0] == ':' && (colon
|| slash
))
1559 /* if dev1:[dir]dev2:, move nm to dev2: */
1565 /* If /name/dev:, move nm to dev: */
1568 /* If node::dev:, move colon following dev */
1569 else if (colon
&& colon
[-1] == ':')
1571 /* If dev1:dev2:, move nm to dev2: */
1572 else if (colon
&& colon
[-1] != ':')
1577 if (p
[0] == ':' && !colon
)
1583 if (lbrack
== rbrack
)
1586 else if (p
[0] == '.')
1594 if (index (nm
, '/'))
1595 return build_string (sys_translate_unix (nm
));
1597 if (nm
== XSTRING (name
)->data
)
1599 return build_string (nm
);
1603 /* Now determine directory to start with and put it in NEWDIR */
1607 if (nm
[0] == '~') /* prefix ~ */
1612 || nm
[1] == 0)/* ~/filename */
1614 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1615 newdir
= (unsigned char *) "";
1618 nm
++; /* Don't leave the slash in nm. */
1621 else /* ~user/filename */
1623 /* Get past ~ to user */
1624 unsigned char *user
= nm
+ 1;
1625 /* Find end of name. */
1626 unsigned char *ptr
= (unsigned char *) index (user
, '/');
1627 int len
= ptr
? ptr
- user
: strlen (user
);
1629 unsigned char *ptr1
= index (user
, ':');
1630 if (ptr1
!= 0 && ptr1
- user
< len
)
1633 /* Copy the user name into temp storage. */
1634 o
= (unsigned char *) alloca (len
+ 1);
1635 bcopy ((char *) user
, o
, len
);
1638 /* Look up the user name. */
1639 pw
= (struct passwd
*) getpwnam (o
+ 1);
1641 error ("\"%s\" isn't a registered user", o
+ 1);
1643 newdir
= (unsigned char *) pw
->pw_dir
;
1645 /* Discard the user name from NM. */
1652 #endif /* not VMS */
1656 defalt
= current_buffer
->directory
;
1657 CHECK_STRING (defalt
, 1);
1658 newdir
= XSTRING (defalt
)->data
;
1661 /* Now concatenate the directory and name to new space in the stack frame */
1663 tlen
= (newdir
? strlen (newdir
) + 1 : 0) + strlen (nm
) + 1;
1664 target
= (unsigned char *) alloca (tlen
);
1670 if (nm
[0] == 0 || nm
[0] == '/')
1671 strcpy (target
, newdir
);
1674 file_name_as_directory (target
, newdir
);
1677 strcat (target
, nm
);
1679 if (index (target
, '/'))
1680 strcpy (target
, sys_translate_unix (target
));
1683 /* Now canonicalize by removing /. and /foo/.. if they appear */
1691 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1697 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1698 /* brackets are offset from each other by 2 */
1701 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1702 /* convert [foo][bar] to [bar] */
1703 while (o
[-1] != '[' && o
[-1] != '<')
1705 else if (*p
== '-' && *o
!= '.')
1708 else if (p
[0] == '-' && o
[-1] == '.' &&
1709 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1710 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1714 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1715 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1717 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1719 /* else [foo.-] ==> [-] */
1725 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1726 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1736 else if (!strncmp (p
, "//", 2)
1738 /* // at start of filename is meaningful in Apollo system. */
1746 else if (p
[0] == '/' && p
[1] == '.' &&
1747 (p
[2] == '/' || p
[2] == 0))
1749 else if (!strncmp (p
, "/..", 3)
1750 /* `/../' is the "superroot" on certain file systems. */
1752 && (p
[3] == '/' || p
[3] == 0))
1754 while (o
!= target
&& *--o
!= '/')
1757 if (o
== target
+ 1 && o
[-1] == '/' && o
[0] == '/')
1761 if (o
== target
&& *o
== '/')
1769 #endif /* not VMS */
1772 return make_string (target
, o
- target
);
1776 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name
,
1777 Ssubstitute_in_file_name
, 1, 1, 0,
1778 "Substitute environment variables referred to in FILENAME.\n\
1779 `$FOO' where FOO is an environment variable name means to substitute\n\
1780 the value of that variable. The variable name should be terminated\n\
1781 with a character not a letter, digit or underscore; otherwise, enclose\n\
1782 the entire variable name in braces.\n\
1783 If `/~' appears, all of FILENAME through that `/' is discarded.\n\n\
1784 On VMS, `$' substitution is not done; this function does little and only\n\
1785 duplicates what `expand-file-name' does.")
1787 Lisp_Object filename
;
1791 register unsigned char *s
, *p
, *o
, *x
, *endp
;
1792 unsigned char *target
;
1794 int substituted
= 0;
1796 Lisp_Object handler
;
1798 CHECK_STRING (filename
, 0);
1800 /* If the file name has special constructs in it,
1801 call the corresponding file handler. */
1802 handler
= Ffind_file_name_handler (filename
, Qsubstitute_in_file_name
);
1803 if (!NILP (handler
))
1804 return call2 (handler
, Qsubstitute_in_file_name
, filename
);
1806 nm
= XSTRING (filename
)->data
;
1808 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
1809 CORRECT_DIR_SEPS (nm
);
1810 substituted
= (strcmp (nm
, XSTRING (filename
)->data
) != 0);
1812 endp
= nm
+ STRING_BYTES (XSTRING (filename
));
1814 /* If /~ or // appears, discard everything through first slash. */
1816 for (p
= nm
; p
!= endp
; p
++)
1819 #if defined (APOLLO) || defined (WINDOWSNT)
1820 /* // at start of file name is meaningful in Apollo and
1821 WindowsNT systems. */
1822 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != nm
)
1823 #else /* not (APOLLO || WINDOWSNT) */
1824 || IS_DIRECTORY_SEP (p
[0])
1825 #endif /* not (APOLLO || WINDOWSNT) */
1830 || p
[-1] == ':' || p
[-1] == ']' || p
[-1] == '>'
1832 || IS_DIRECTORY_SEP (p
[-1])))
1838 /* see comment in expand-file-name about drive specifiers */
1839 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
1840 && p
> nm
&& IS_DIRECTORY_SEP (p
[-1]))
1849 return build_string (nm
);
1852 /* See if any variables are substituted into the string
1853 and find the total length of their values in `total' */
1855 for (p
= nm
; p
!= endp
;)
1865 /* "$$" means a single "$" */
1874 while (p
!= endp
&& *p
!= '}') p
++;
1875 if (*p
!= '}') goto missingclose
;
1881 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1885 /* Copy out the variable name */
1886 target
= (unsigned char *) alloca (s
- o
+ 1);
1887 strncpy (target
, o
, s
- o
);
1890 strupr (target
); /* $home == $HOME etc. */
1893 /* Get variable value */
1894 o
= (unsigned char *) egetenv (target
);
1895 if (!o
) goto badvar
;
1896 total
+= strlen (o
);
1903 /* If substitution required, recopy the string and do it */
1904 /* Make space in stack frame for the new copy */
1905 xnm
= (unsigned char *) alloca (STRING_BYTES (XSTRING (filename
)) + total
+ 1);
1908 /* Copy the rest of the name through, replacing $ constructs with values */
1925 while (p
!= endp
&& *p
!= '}') p
++;
1926 if (*p
!= '}') goto missingclose
;
1932 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1936 /* Copy out the variable name */
1937 target
= (unsigned char *) alloca (s
- o
+ 1);
1938 strncpy (target
, o
, s
- o
);
1941 strupr (target
); /* $home == $HOME etc. */
1944 /* Get variable value */
1945 o
= (unsigned char *) egetenv (target
);
1949 if (STRING_MULTIBYTE (filename
))
1951 /* If the original string is multibyte,
1952 convert what we substitute into multibyte. */
1953 unsigned char workbuf
[4], *str
;
1959 c
= unibyte_char_to_multibyte (c
);
1960 if (! SINGLE_BYTE_CHAR_P (c
))
1962 len
= CHAR_STRING (c
, workbuf
, str
);
1963 bcopy (str
, x
, len
);
1979 /* If /~ or // appears, discard everything through first slash. */
1981 for (p
= xnm
; p
!= x
; p
++)
1983 #if defined (APOLLO) || defined (WINDOWSNT)
1984 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != xnm
)
1985 #else /* not (APOLLO || WINDOWSNT) */
1986 || IS_DIRECTORY_SEP (p
[0])
1987 #endif /* not (APOLLO || WINDOWSNT) */
1989 && p
!= xnm
&& IS_DIRECTORY_SEP (p
[-1]))
1992 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
1993 && p
> nm
&& IS_DIRECTORY_SEP (p
[-1]))
1997 if (STRING_MULTIBYTE (filename
))
1998 return make_string (xnm
, x
- xnm
);
1999 return make_unibyte_string (xnm
, x
- xnm
);
2002 error ("Bad format environment-variable substitution");
2004 error ("Missing \"}\" in environment-variable substitution");
2006 error ("Substituting nonexistent environment variable \"%s\"", target
);
2009 #endif /* not VMS */
2012 /* A slightly faster and more convenient way to get
2013 (directory-file-name (expand-file-name FOO)). */
2016 expand_and_dir_to_file (filename
, defdir
)
2017 Lisp_Object filename
, defdir
;
2019 register Lisp_Object absname
;
2021 absname
= Fexpand_file_name (filename
, defdir
);
2024 register int c
= XSTRING (absname
)->data
[STRING_BYTES (XSTRING (absname
)) - 1];
2025 if (c
== ':' || c
== ']' || c
== '>')
2026 absname
= Fdirectory_file_name (absname
);
2029 /* Remove final slash, if any (unless this is the root dir).
2030 stat behaves differently depending! */
2031 if (XSTRING (absname
)->size
> 1
2032 && IS_DIRECTORY_SEP (XSTRING (absname
)->data
[STRING_BYTES (XSTRING (absname
)) - 1])
2033 && !IS_DEVICE_SEP (XSTRING (absname
)->data
[STRING_BYTES (XSTRING (absname
))-2]))
2034 /* We cannot take shortcuts; they might be wrong for magic file names. */
2035 absname
= Fdirectory_file_name (absname
);
2040 /* Signal an error if the file ABSNAME already exists.
2041 If INTERACTIVE is nonzero, ask the user whether to proceed,
2042 and bypass the error if the user says to go ahead.
2043 QUERYSTRING is a name for the action that is being considered
2046 *STATPTR is used to store the stat information if the file exists.
2047 If the file does not exist, STATPTR->st_mode is set to 0.
2048 If STATPTR is null, we don't store into it.
2050 If QUICK is nonzero, we ask for y or n, not yes or no. */
2053 barf_or_query_if_file_exists (absname
, querystring
, interactive
, statptr
, quick
)
2054 Lisp_Object absname
;
2055 unsigned char *querystring
;
2057 struct stat
*statptr
;
2060 register Lisp_Object tem
;
2061 struct stat statbuf
;
2062 struct gcpro gcpro1
;
2064 /* stat is a good way to tell whether the file exists,
2065 regardless of what access permissions it has. */
2066 if (stat (XSTRING (absname
)->data
, &statbuf
) >= 0)
2069 Fsignal (Qfile_already_exists
,
2070 Fcons (build_string ("File already exists"),
2071 Fcons (absname
, Qnil
)));
2073 tem
= format1 ("File %s already exists; %s anyway? ",
2074 XSTRING (absname
)->data
, querystring
);
2076 tem
= Fy_or_n_p (tem
);
2078 tem
= do_yes_or_no_p (tem
);
2081 Fsignal (Qfile_already_exists
,
2082 Fcons (build_string ("File already exists"),
2083 Fcons (absname
, Qnil
)));
2090 statptr
->st_mode
= 0;
2095 DEFUN ("copy-file", Fcopy_file
, Scopy_file
, 2, 4,
2096 "fCopy file: \nFCopy %s to file: \np\nP",
2097 "Copy FILE to NEWNAME. Both args must be strings.\n\
2098 Signals a `file-already-exists' error if file NEWNAME already exists,\n\
2099 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.\n\
2100 A number as third arg means request confirmation if NEWNAME already exists.\n\
2101 This is what happens in interactive use with M-x.\n\
2102 Fourth arg KEEP-TIME non-nil means give the new file the same\n\
2103 last-modified time as the old one. (This works on only some systems.)\n\
2104 A prefix arg makes KEEP-TIME non-nil.")
2105 (file
, newname
, ok_if_already_exists
, keep_date
)
2106 Lisp_Object file
, newname
, ok_if_already_exists
, keep_date
;
2109 char buf
[16 * 1024];
2110 struct stat st
, out_st
;
2111 Lisp_Object handler
;
2112 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2113 int count
= specpdl_ptr
- specpdl
;
2114 int input_file_statable_p
;
2115 Lisp_Object encoded_file
, encoded_newname
;
2117 encoded_file
= encoded_newname
= Qnil
;
2118 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2119 CHECK_STRING (file
, 0);
2120 CHECK_STRING (newname
, 1);
2122 file
= Fexpand_file_name (file
, Qnil
);
2123 newname
= Fexpand_file_name (newname
, Qnil
);
2125 /* If the input file name has special constructs in it,
2126 call the corresponding file handler. */
2127 handler
= Ffind_file_name_handler (file
, Qcopy_file
);
2128 /* Likewise for output file name. */
2130 handler
= Ffind_file_name_handler (newname
, Qcopy_file
);
2131 if (!NILP (handler
))
2132 RETURN_UNGCPRO (call5 (handler
, Qcopy_file
, file
, newname
,
2133 ok_if_already_exists
, keep_date
));
2135 encoded_file
= ENCODE_FILE (file
);
2136 encoded_newname
= ENCODE_FILE (newname
);
2138 if (NILP (ok_if_already_exists
)
2139 || INTEGERP (ok_if_already_exists
))
2140 barf_or_query_if_file_exists (encoded_newname
, "copy to it",
2141 INTEGERP (ok_if_already_exists
), &out_st
, 0);
2142 else if (stat (XSTRING (encoded_newname
)->data
, &out_st
) < 0)
2145 ifd
= open (XSTRING (encoded_file
)->data
, O_RDONLY
);
2147 report_file_error ("Opening input file", Fcons (file
, Qnil
));
2149 record_unwind_protect (close_file_unwind
, make_number (ifd
));
2151 /* We can only copy regular files and symbolic links. Other files are not
2153 input_file_statable_p
= (fstat (ifd
, &st
) >= 0);
2155 #if !defined (MSDOS) || __DJGPP__ > 1
2156 if (out_st
.st_mode
!= 0
2157 && st
.st_dev
== out_st
.st_dev
&& st
.st_ino
== out_st
.st_ino
)
2160 report_file_error ("Input and output files are the same",
2161 Fcons (file
, Fcons (newname
, Qnil
)));
2165 #if defined (S_ISREG) && defined (S_ISLNK)
2166 if (input_file_statable_p
)
2168 if (!(S_ISREG (st
.st_mode
)) && !(S_ISLNK (st
.st_mode
)))
2170 #if defined (EISDIR)
2171 /* Get a better looking error message. */
2174 report_file_error ("Non-regular file", Fcons (file
, Qnil
));
2177 #endif /* S_ISREG && S_ISLNK */
2180 /* Create the copy file with the same record format as the input file */
2181 ofd
= sys_creat (XSTRING (encoded_newname
)->data
, 0666, ifd
);
2184 /* System's default file type was set to binary by _fmode in emacs.c. */
2185 ofd
= creat (XSTRING (encoded_newname
)->data
, S_IREAD
| S_IWRITE
);
2186 #else /* not MSDOS */
2187 ofd
= creat (XSTRING (encoded_newname
)->data
, 0666);
2188 #endif /* not MSDOS */
2191 report_file_error ("Opening output file", Fcons (newname
, Qnil
));
2193 record_unwind_protect (close_file_unwind
, make_number (ofd
));
2197 while ((n
= read (ifd
, buf
, sizeof buf
)) > 0)
2198 if (write (ofd
, buf
, n
) != n
)
2199 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2202 /* Closing the output clobbers the file times on some systems. */
2203 if (close (ofd
) < 0)
2204 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2206 if (input_file_statable_p
)
2208 if (!NILP (keep_date
))
2210 EMACS_TIME atime
, mtime
;
2211 EMACS_SET_SECS_USECS (atime
, st
.st_atime
, 0);
2212 EMACS_SET_SECS_USECS (mtime
, st
.st_mtime
, 0);
2213 if (set_file_times (XSTRING (encoded_newname
)->data
,
2215 Fsignal (Qfile_date_error
,
2216 Fcons (build_string ("Cannot set file date"),
2217 Fcons (newname
, Qnil
)));
2220 chmod (XSTRING (encoded_newname
)->data
, st
.st_mode
& 07777);
2222 #if defined (__DJGPP__) && __DJGPP__ > 1
2223 /* In DJGPP v2.0 and later, fstat usually returns true file mode bits,
2224 and if it can't, it tells so. Otherwise, under MSDOS we usually
2225 get only the READ bit, which will make the copied file read-only,
2226 so it's better not to chmod at all. */
2227 if ((_djstat_flags
& _STFAIL_WRITEBIT
) == 0)
2228 chmod (XSTRING (encoded_newname
)->data
, st
.st_mode
& 07777);
2229 #endif /* DJGPP version 2 or newer */
2235 /* Discard the unwind protects. */
2236 specpdl_ptr
= specpdl
+ count
;
2242 DEFUN ("make-directory-internal", Fmake_directory_internal
,
2243 Smake_directory_internal
, 1, 1, 0,
2244 "Create a new directory named DIRECTORY.")
2246 Lisp_Object directory
;
2249 Lisp_Object handler
;
2250 Lisp_Object encoded_dir
;
2252 CHECK_STRING (directory
, 0);
2253 directory
= Fexpand_file_name (directory
, Qnil
);
2255 handler
= Ffind_file_name_handler (directory
, Qmake_directory_internal
);
2256 if (!NILP (handler
))
2257 return call2 (handler
, Qmake_directory_internal
, directory
);
2259 encoded_dir
= ENCODE_FILE (directory
);
2261 dir
= XSTRING (encoded_dir
)->data
;
2264 if (mkdir (dir
) != 0)
2266 if (mkdir (dir
, 0777) != 0)
2268 report_file_error ("Creating directory", Flist (1, &directory
));
2273 DEFUN ("delete-directory", Fdelete_directory
, Sdelete_directory
, 1, 1, "FDelete directory: ",
2274 "Delete the directory named DIRECTORY.")
2276 Lisp_Object directory
;
2279 Lisp_Object handler
;
2280 Lisp_Object encoded_dir
;
2282 CHECK_STRING (directory
, 0);
2283 directory
= Fdirectory_file_name (Fexpand_file_name (directory
, Qnil
));
2285 handler
= Ffind_file_name_handler (directory
, Qdelete_directory
);
2286 if (!NILP (handler
))
2287 return call2 (handler
, Qdelete_directory
, directory
);
2289 encoded_dir
= ENCODE_FILE (directory
);
2291 dir
= XSTRING (encoded_dir
)->data
;
2293 if (rmdir (dir
) != 0)
2294 report_file_error ("Removing directory", Flist (1, &directory
));
2299 DEFUN ("delete-file", Fdelete_file
, Sdelete_file
, 1, 1, "fDelete file: ",
2300 "Delete file named FILENAME.\n\
2301 If file has multiple names, it continues to exist with the other names.")
2303 Lisp_Object filename
;
2305 Lisp_Object handler
;
2306 Lisp_Object encoded_file
;
2308 CHECK_STRING (filename
, 0);
2309 filename
= Fexpand_file_name (filename
, Qnil
);
2311 handler
= Ffind_file_name_handler (filename
, Qdelete_file
);
2312 if (!NILP (handler
))
2313 return call2 (handler
, Qdelete_file
, filename
);
2315 encoded_file
= ENCODE_FILE (filename
);
2317 if (0 > unlink (XSTRING (encoded_file
)->data
))
2318 report_file_error ("Removing old name", Flist (1, &filename
));
2323 internal_delete_file_1 (ignore
)
2329 /* Delete file FILENAME, returning 1 if successful and 0 if failed. */
2332 internal_delete_file (filename
)
2333 Lisp_Object filename
;
2335 return NILP (internal_condition_case_1 (Fdelete_file
, filename
,
2336 Qt
, internal_delete_file_1
));
2339 DEFUN ("rename-file", Frename_file
, Srename_file
, 2, 3,
2340 "fRename file: \nFRename %s to file: \np",
2341 "Rename FILE as NEWNAME. Both args strings.\n\
2342 If file has names other than FILE, it continues to have those names.\n\
2343 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2344 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2345 A number as third arg means request confirmation if NEWNAME already exists.\n\
2346 This is what happens in interactive use with M-x.")
2347 (file
, newname
, ok_if_already_exists
)
2348 Lisp_Object file
, newname
, ok_if_already_exists
;
2351 Lisp_Object args
[2];
2353 Lisp_Object handler
;
2354 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2355 Lisp_Object encoded_file
, encoded_newname
;
2357 encoded_file
= encoded_newname
= Qnil
;
2358 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2359 CHECK_STRING (file
, 0);
2360 CHECK_STRING (newname
, 1);
2361 file
= Fexpand_file_name (file
, Qnil
);
2362 newname
= Fexpand_file_name (newname
, Qnil
);
2364 /* If the file name has special constructs in it,
2365 call the corresponding file handler. */
2366 handler
= Ffind_file_name_handler (file
, Qrename_file
);
2368 handler
= Ffind_file_name_handler (newname
, Qrename_file
);
2369 if (!NILP (handler
))
2370 RETURN_UNGCPRO (call4 (handler
, Qrename_file
,
2371 file
, newname
, ok_if_already_exists
));
2373 encoded_file
= ENCODE_FILE (file
);
2374 encoded_newname
= ENCODE_FILE (newname
);
2376 if (NILP (ok_if_already_exists
)
2377 || INTEGERP (ok_if_already_exists
))
2378 barf_or_query_if_file_exists (encoded_newname
, "rename to it",
2379 INTEGERP (ok_if_already_exists
), 0, 0);
2381 if (0 > rename (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
))
2383 if (0 > link (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
)
2384 || 0 > unlink (XSTRING (encoded_file
)->data
))
2389 Fcopy_file (file
, newname
,
2390 /* We have already prompted if it was an integer,
2391 so don't have copy-file prompt again. */
2392 NILP (ok_if_already_exists
) ? Qnil
: Qt
, Qt
);
2393 Fdelete_file (file
);
2400 report_file_error ("Renaming", Flist (2, args
));
2403 report_file_error ("Renaming", Flist (2, &file
));
2410 DEFUN ("add-name-to-file", Fadd_name_to_file
, Sadd_name_to_file
, 2, 3,
2411 "fAdd name to file: \nFName to add to %s: \np",
2412 "Give FILE additional name NEWNAME. Both args strings.\n\
2413 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2414 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2415 A number as third arg means request confirmation if NEWNAME already exists.\n\
2416 This is what happens in interactive use with M-x.")
2417 (file
, newname
, ok_if_already_exists
)
2418 Lisp_Object file
, newname
, ok_if_already_exists
;
2421 Lisp_Object args
[2];
2423 Lisp_Object handler
;
2424 Lisp_Object encoded_file
, encoded_newname
;
2425 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2427 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2428 encoded_file
= encoded_newname
= Qnil
;
2429 CHECK_STRING (file
, 0);
2430 CHECK_STRING (newname
, 1);
2431 file
= Fexpand_file_name (file
, Qnil
);
2432 newname
= Fexpand_file_name (newname
, Qnil
);
2434 /* If the file name has special constructs in it,
2435 call the corresponding file handler. */
2436 handler
= Ffind_file_name_handler (file
, Qadd_name_to_file
);
2437 if (!NILP (handler
))
2438 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2439 newname
, ok_if_already_exists
));
2441 /* If the new name has special constructs in it,
2442 call the corresponding file handler. */
2443 handler
= Ffind_file_name_handler (newname
, Qadd_name_to_file
);
2444 if (!NILP (handler
))
2445 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2446 newname
, ok_if_already_exists
));
2448 encoded_file
= ENCODE_FILE (file
);
2449 encoded_newname
= ENCODE_FILE (newname
);
2451 if (NILP (ok_if_already_exists
)
2452 || INTEGERP (ok_if_already_exists
))
2453 barf_or_query_if_file_exists (encoded_newname
, "make it a new name",
2454 INTEGERP (ok_if_already_exists
), 0, 0);
2456 unlink (XSTRING (newname
)->data
);
2457 if (0 > link (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
))
2462 report_file_error ("Adding new name", Flist (2, args
));
2464 report_file_error ("Adding new name", Flist (2, &file
));
2473 DEFUN ("make-symbolic-link", Fmake_symbolic_link
, Smake_symbolic_link
, 2, 3,
2474 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np",
2475 "Make a symbolic link to FILENAME, named LINKNAME. Both args strings.\n\
2476 Signals a `file-already-exists' error if a file LINKNAME already exists\n\
2477 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2478 A number as third arg means request confirmation if LINKNAME already exists.\n\
2479 This happens for interactive use with M-x.")
2480 (filename
, linkname
, ok_if_already_exists
)
2481 Lisp_Object filename
, linkname
, ok_if_already_exists
;
2484 Lisp_Object args
[2];
2486 Lisp_Object handler
;
2487 Lisp_Object encoded_filename
, encoded_linkname
;
2488 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2490 GCPRO4 (filename
, linkname
, encoded_filename
, encoded_linkname
);
2491 encoded_filename
= encoded_linkname
= Qnil
;
2492 CHECK_STRING (filename
, 0);
2493 CHECK_STRING (linkname
, 1);
2494 /* If the link target has a ~, we must expand it to get
2495 a truly valid file name. Otherwise, do not expand;
2496 we want to permit links to relative file names. */
2497 if (XSTRING (filename
)->data
[0] == '~')
2498 filename
= Fexpand_file_name (filename
, Qnil
);
2499 linkname
= Fexpand_file_name (linkname
, Qnil
);
2501 /* If the file name has special constructs in it,
2502 call the corresponding file handler. */
2503 handler
= Ffind_file_name_handler (filename
, Qmake_symbolic_link
);
2504 if (!NILP (handler
))
2505 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2506 linkname
, ok_if_already_exists
));
2508 /* If the new link name has special constructs in it,
2509 call the corresponding file handler. */
2510 handler
= Ffind_file_name_handler (linkname
, Qmake_symbolic_link
);
2511 if (!NILP (handler
))
2512 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2513 linkname
, ok_if_already_exists
));
2515 encoded_filename
= ENCODE_FILE (filename
);
2516 encoded_linkname
= ENCODE_FILE (linkname
);
2518 if (NILP (ok_if_already_exists
)
2519 || INTEGERP (ok_if_already_exists
))
2520 barf_or_query_if_file_exists (encoded_linkname
, "make it a link",
2521 INTEGERP (ok_if_already_exists
), 0, 0);
2522 if (0 > symlink (XSTRING (encoded_filename
)->data
,
2523 XSTRING (encoded_linkname
)->data
))
2525 /* If we didn't complain already, silently delete existing file. */
2526 if (errno
== EEXIST
)
2528 unlink (XSTRING (encoded_linkname
)->data
);
2529 if (0 <= symlink (XSTRING (encoded_filename
)->data
,
2530 XSTRING (encoded_linkname
)->data
))
2540 report_file_error ("Making symbolic link", Flist (2, args
));
2542 report_file_error ("Making symbolic link", Flist (2, &filename
));
2548 #endif /* S_IFLNK */
2552 DEFUN ("define-logical-name", Fdefine_logical_name
, Sdefine_logical_name
,
2553 2, 2, "sDefine logical name: \nsDefine logical name %s as: ",
2554 "Define the job-wide logical name NAME to have the value STRING.\n\
2555 If STRING is nil or a null string, the logical name NAME is deleted.")
2560 CHECK_STRING (name
, 0);
2562 delete_logical_name (XSTRING (name
)->data
);
2565 CHECK_STRING (string
, 1);
2567 if (XSTRING (string
)->size
== 0)
2568 delete_logical_name (XSTRING (name
)->data
);
2570 define_logical_name (XSTRING (name
)->data
, XSTRING (string
)->data
);
2579 DEFUN ("sysnetunam", Fsysnetunam
, Ssysnetunam
, 2, 2, 0,
2580 "Open a network connection to PATH using LOGIN as the login string.")
2582 Lisp_Object path
, login
;
2586 CHECK_STRING (path
, 0);
2587 CHECK_STRING (login
, 0);
2589 netresult
= netunam (XSTRING (path
)->data
, XSTRING (login
)->data
);
2591 if (netresult
== -1)
2596 #endif /* HPUX_NET */
2598 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p
, Sfile_name_absolute_p
,
2600 "Return t if file FILENAME specifies an absolute file name.\n\
2601 On Unix, this is a name starting with a `/' or a `~'.")
2603 Lisp_Object filename
;
2607 CHECK_STRING (filename
, 0);
2608 ptr
= XSTRING (filename
)->data
;
2609 if (IS_DIRECTORY_SEP (*ptr
) || *ptr
== '~'
2611 /* ??? This criterion is probably wrong for '<'. */
2612 || index (ptr
, ':') || index (ptr
, '<')
2613 || (*ptr
== '[' && (ptr
[1] != '-' || (ptr
[2] != '.' && ptr
[2] != ']'))
2617 || (IS_DRIVE (*ptr
) && ptr
[1] == ':' && IS_DIRECTORY_SEP (ptr
[2]))
2625 /* Return nonzero if file FILENAME exists and can be executed. */
2628 check_executable (filename
)
2632 int len
= strlen (filename
);
2635 if (stat (filename
, &st
) < 0)
2637 #if defined (WINDOWSNT) || (defined (MSDOS) && __DJGPP__ > 1)
2638 return ((st
.st_mode
& S_IEXEC
) != 0);
2640 return (S_ISREG (st
.st_mode
)
2642 && (stricmp ((suffix
= filename
+ len
-4), ".com") == 0
2643 || stricmp (suffix
, ".exe") == 0
2644 || stricmp (suffix
, ".bat") == 0)
2645 || (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2646 #endif /* not WINDOWSNT */
2647 #else /* not DOS_NT */
2648 #ifdef HAVE_EUIDACCESS
2649 return (euidaccess (filename
, 1) >= 0);
2651 /* Access isn't quite right because it uses the real uid
2652 and we really want to test with the effective uid.
2653 But Unix doesn't give us a right way to do it. */
2654 return (access (filename
, 1) >= 0);
2656 #endif /* not DOS_NT */
2659 /* Return nonzero if file FILENAME exists and can be written. */
2662 check_writable (filename
)
2667 if (stat (filename
, &st
) < 0)
2669 return (st
.st_mode
& S_IWRITE
|| (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2670 #else /* not MSDOS */
2671 #ifdef HAVE_EUIDACCESS
2672 return (euidaccess (filename
, 2) >= 0);
2674 /* Access isn't quite right because it uses the real uid
2675 and we really want to test with the effective uid.
2676 But Unix doesn't give us a right way to do it.
2677 Opening with O_WRONLY could work for an ordinary file,
2678 but would lose for directories. */
2679 return (access (filename
, 2) >= 0);
2681 #endif /* not MSDOS */
2684 DEFUN ("file-exists-p", Ffile_exists_p
, Sfile_exists_p
, 1, 1, 0,
2685 "Return t if file FILENAME exists. (This does not mean you can read it.)\n\
2686 See also `file-readable-p' and `file-attributes'.")
2688 Lisp_Object filename
;
2690 Lisp_Object absname
;
2691 Lisp_Object handler
;
2692 struct stat statbuf
;
2694 CHECK_STRING (filename
, 0);
2695 absname
= Fexpand_file_name (filename
, Qnil
);
2697 /* If the file name has special constructs in it,
2698 call the corresponding file handler. */
2699 handler
= Ffind_file_name_handler (absname
, Qfile_exists_p
);
2700 if (!NILP (handler
))
2701 return call2 (handler
, Qfile_exists_p
, absname
);
2703 absname
= ENCODE_FILE (absname
);
2705 return (stat (XSTRING (absname
)->data
, &statbuf
) >= 0) ? Qt
: Qnil
;
2708 DEFUN ("file-executable-p", Ffile_executable_p
, Sfile_executable_p
, 1, 1, 0,
2709 "Return t if FILENAME can be executed by you.\n\
2710 For a directory, this means you can access files in that directory.")
2712 Lisp_Object filename
;
2715 Lisp_Object absname
;
2716 Lisp_Object handler
;
2718 CHECK_STRING (filename
, 0);
2719 absname
= Fexpand_file_name (filename
, Qnil
);
2721 /* If the file name has special constructs in it,
2722 call the corresponding file handler. */
2723 handler
= Ffind_file_name_handler (absname
, Qfile_executable_p
);
2724 if (!NILP (handler
))
2725 return call2 (handler
, Qfile_executable_p
, absname
);
2727 absname
= ENCODE_FILE (absname
);
2729 return (check_executable (XSTRING (absname
)->data
) ? Qt
: Qnil
);
2732 DEFUN ("file-readable-p", Ffile_readable_p
, Sfile_readable_p
, 1, 1, 0,
2733 "Return t if file FILENAME exists and you can read it.\n\
2734 See also `file-exists-p' and `file-attributes'.")
2736 Lisp_Object filename
;
2738 Lisp_Object absname
;
2739 Lisp_Object handler
;
2742 struct stat statbuf
;
2744 CHECK_STRING (filename
, 0);
2745 absname
= Fexpand_file_name (filename
, Qnil
);
2747 /* If the file name has special constructs in it,
2748 call the corresponding file handler. */
2749 handler
= Ffind_file_name_handler (absname
, Qfile_readable_p
);
2750 if (!NILP (handler
))
2751 return call2 (handler
, Qfile_readable_p
, absname
);
2753 absname
= ENCODE_FILE (absname
);
2756 /* Under MS-DOS and Windows, open does not work for directories. */
2757 if (access (XSTRING (absname
)->data
, 0) == 0)
2760 #else /* not DOS_NT */
2762 #if defined (S_ISFIFO) && defined (O_NONBLOCK)
2763 /* Opening a fifo without O_NONBLOCK can wait.
2764 We don't want to wait. But we don't want to mess wth O_NONBLOCK
2765 except in the case of a fifo, on a system which handles it. */
2766 desc
= stat (XSTRING (absname
)->data
, &statbuf
);
2769 if (S_ISFIFO (statbuf
.st_mode
))
2770 flags
|= O_NONBLOCK
;
2772 desc
= open (XSTRING (absname
)->data
, flags
);
2777 #endif /* not DOS_NT */
2780 /* Having this before file-symlink-p mysteriously caused it to be forgotten
2782 DEFUN ("file-writable-p", Ffile_writable_p
, Sfile_writable_p
, 1, 1, 0,
2783 "Return t if file FILENAME can be written or created by you.")
2785 Lisp_Object filename
;
2787 Lisp_Object absname
, dir
, encoded
;
2788 Lisp_Object handler
;
2789 struct stat statbuf
;
2791 CHECK_STRING (filename
, 0);
2792 absname
= Fexpand_file_name (filename
, Qnil
);
2794 /* If the file name has special constructs in it,
2795 call the corresponding file handler. */
2796 handler
= Ffind_file_name_handler (absname
, Qfile_writable_p
);
2797 if (!NILP (handler
))
2798 return call2 (handler
, Qfile_writable_p
, absname
);
2800 encoded
= ENCODE_FILE (absname
);
2801 if (stat (XSTRING (encoded
)->data
, &statbuf
) >= 0)
2802 return (check_writable (XSTRING (encoded
)->data
)
2805 dir
= Ffile_name_directory (absname
);
2808 dir
= Fdirectory_file_name (dir
);
2812 dir
= Fdirectory_file_name (dir
);
2815 dir
= ENCODE_FILE (dir
);
2816 return (check_writable (!NILP (dir
) ? (char *) XSTRING (dir
)->data
: "")
2820 DEFUN ("access-file", Faccess_file
, Saccess_file
, 2, 2, 0,
2821 "Access file FILENAME, and get an error if that does not work.\n\
2822 The second argument STRING is used in the error message.\n\
2823 If there is no error, we return nil.")
2825 Lisp_Object filename
, string
;
2827 Lisp_Object handler
, encoded_filename
;
2830 CHECK_STRING (filename
, 0);
2832 /* If the file name has special constructs in it,
2833 call the corresponding file handler. */
2834 handler
= Ffind_file_name_handler (filename
, Qaccess_file
);
2835 if (!NILP (handler
))
2836 return call3 (handler
, Qaccess_file
, filename
, string
);
2838 encoded_filename
= ENCODE_FILE (filename
);
2840 fd
= open (XSTRING (encoded_filename
)->data
, O_RDONLY
);
2842 report_file_error (XSTRING (string
)->data
, Fcons (filename
, Qnil
));
2848 DEFUN ("file-symlink-p", Ffile_symlink_p
, Sfile_symlink_p
, 1, 1, 0,
2849 "Return non-nil if file FILENAME is the name of a symbolic link.\n\
2850 The value is the name of the file to which it is linked.\n\
2851 Otherwise returns nil.")
2853 Lisp_Object filename
;
2860 Lisp_Object handler
;
2862 CHECK_STRING (filename
, 0);
2863 filename
= Fexpand_file_name (filename
, Qnil
);
2865 /* If the file name has special constructs in it,
2866 call the corresponding file handler. */
2867 handler
= Ffind_file_name_handler (filename
, Qfile_symlink_p
);
2868 if (!NILP (handler
))
2869 return call2 (handler
, Qfile_symlink_p
, filename
);
2871 filename
= ENCODE_FILE (filename
);
2876 buf
= (char *) xmalloc (bufsize
);
2877 bzero (buf
, bufsize
);
2878 valsize
= readlink (XSTRING (filename
)->data
, buf
, bufsize
);
2879 if (valsize
< bufsize
) break;
2880 /* Buffer was not long enough */
2889 val
= make_string (buf
, valsize
);
2891 val
= DECODE_FILE (val
);
2893 #else /* not S_IFLNK */
2895 #endif /* not S_IFLNK */
2898 DEFUN ("file-directory-p", Ffile_directory_p
, Sfile_directory_p
, 1, 1, 0,
2899 "Return t if FILENAME names an existing directory.")
2901 Lisp_Object filename
;
2903 register Lisp_Object absname
;
2905 Lisp_Object handler
;
2907 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2909 /* If the file name has special constructs in it,
2910 call the corresponding file handler. */
2911 handler
= Ffind_file_name_handler (absname
, Qfile_directory_p
);
2912 if (!NILP (handler
))
2913 return call2 (handler
, Qfile_directory_p
, absname
);
2915 absname
= ENCODE_FILE (absname
);
2917 if (stat (XSTRING (absname
)->data
, &st
) < 0)
2919 return (st
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
2922 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p
, Sfile_accessible_directory_p
, 1, 1, 0,
2923 "Return t if file FILENAME is the name of a directory as a file,\n\
2924 and files in that directory can be opened by you. In order to use a\n\
2925 directory as a buffer's current directory, this predicate must return true.\n\
2926 A directory name spec may be given instead; then the value is t\n\
2927 if the directory so specified exists and really is a readable and\n\
2928 searchable directory.")
2930 Lisp_Object filename
;
2932 Lisp_Object handler
;
2934 struct gcpro gcpro1
;
2936 /* If the file name has special constructs in it,
2937 call the corresponding file handler. */
2938 handler
= Ffind_file_name_handler (filename
, Qfile_accessible_directory_p
);
2939 if (!NILP (handler
))
2940 return call2 (handler
, Qfile_accessible_directory_p
, filename
);
2942 /* It's an unlikely combination, but yes we really do need to gcpro:
2943 Suppose that file-accessible-directory-p has no handler, but
2944 file-directory-p does have a handler; this handler causes a GC which
2945 relocates the string in `filename'; and finally file-directory-p
2946 returns non-nil. Then we would end up passing a garbaged string
2947 to file-executable-p. */
2949 tem
= (NILP (Ffile_directory_p (filename
))
2950 || NILP (Ffile_executable_p (filename
)));
2952 return tem
? Qnil
: Qt
;
2955 DEFUN ("file-regular-p", Ffile_regular_p
, Sfile_regular_p
, 1, 1, 0,
2956 "Return t if file FILENAME is the name of a regular file.\n\
2957 This is the sort of file that holds an ordinary stream of data bytes.")
2959 Lisp_Object filename
;
2961 register Lisp_Object absname
;
2963 Lisp_Object handler
;
2965 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2967 /* If the file name has special constructs in it,
2968 call the corresponding file handler. */
2969 handler
= Ffind_file_name_handler (absname
, Qfile_regular_p
);
2970 if (!NILP (handler
))
2971 return call2 (handler
, Qfile_regular_p
, absname
);
2973 absname
= ENCODE_FILE (absname
);
2975 if (stat (XSTRING (absname
)->data
, &st
) < 0)
2977 return (st
.st_mode
& S_IFMT
) == S_IFREG
? Qt
: Qnil
;
2980 DEFUN ("file-modes", Ffile_modes
, Sfile_modes
, 1, 1, 0,
2981 "Return mode bits of file named FILENAME, as an integer.")
2983 Lisp_Object filename
;
2985 Lisp_Object absname
;
2987 Lisp_Object handler
;
2989 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2991 /* If the file name has special constructs in it,
2992 call the corresponding file handler. */
2993 handler
= Ffind_file_name_handler (absname
, Qfile_modes
);
2994 if (!NILP (handler
))
2995 return call2 (handler
, Qfile_modes
, absname
);
2997 absname
= ENCODE_FILE (absname
);
2999 if (stat (XSTRING (absname
)->data
, &st
) < 0)
3001 #if defined (MSDOS) && __DJGPP__ < 2
3002 if (check_executable (XSTRING (absname
)->data
))
3003 st
.st_mode
|= S_IEXEC
;
3004 #endif /* MSDOS && __DJGPP__ < 2 */
3006 return make_number (st
.st_mode
& 07777);
3009 DEFUN ("set-file-modes", Fset_file_modes
, Sset_file_modes
, 2, 2, 0,
3010 "Set mode bits of file named FILENAME to MODE (an integer).\n\
3011 Only the 12 low bits of MODE are used.")
3013 Lisp_Object filename
, mode
;
3015 Lisp_Object absname
, encoded_absname
;
3016 Lisp_Object handler
;
3018 absname
= Fexpand_file_name (filename
, current_buffer
->directory
);
3019 CHECK_NUMBER (mode
, 1);
3021 /* If the file name has special constructs in it,
3022 call the corresponding file handler. */
3023 handler
= Ffind_file_name_handler (absname
, Qset_file_modes
);
3024 if (!NILP (handler
))
3025 return call3 (handler
, Qset_file_modes
, absname
, mode
);
3027 encoded_absname
= ENCODE_FILE (absname
);
3029 if (chmod (XSTRING (encoded_absname
)->data
, XINT (mode
)) < 0)
3030 report_file_error ("Doing chmod", Fcons (absname
, Qnil
));
3035 DEFUN ("set-default-file-modes", Fset_default_file_modes
, Sset_default_file_modes
, 1, 1, 0,
3036 "Set the file permission bits for newly created files.\n\
3037 The argument MODE should be an integer; only the low 9 bits are used.\n\
3038 This setting is inherited by subprocesses.")
3042 CHECK_NUMBER (mode
, 0);
3044 umask ((~ XINT (mode
)) & 0777);
3049 DEFUN ("default-file-modes", Fdefault_file_modes
, Sdefault_file_modes
, 0, 0, 0,
3050 "Return the default file protection for created files.\n\
3051 The value is an integer.")
3057 realmask
= umask (0);
3060 XSETINT (value
, (~ realmask
) & 0777);
3066 DEFUN ("unix-sync", Funix_sync
, Sunix_sync
, 0, 0, "",
3067 "Tell Unix to finish all pending disk updates.")
3076 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p
, Sfile_newer_than_file_p
, 2, 2, 0,
3077 "Return t if file FILE1 is newer than file FILE2.\n\
3078 If FILE1 does not exist, the answer is nil;\n\
3079 otherwise, if FILE2 does not exist, the answer is t.")
3081 Lisp_Object file1
, file2
;
3083 Lisp_Object absname1
, absname2
;
3086 Lisp_Object handler
;
3087 struct gcpro gcpro1
, gcpro2
;
3089 CHECK_STRING (file1
, 0);
3090 CHECK_STRING (file2
, 0);
3093 GCPRO2 (absname1
, file2
);
3094 absname1
= expand_and_dir_to_file (file1
, current_buffer
->directory
);
3095 absname2
= expand_and_dir_to_file (file2
, current_buffer
->directory
);
3098 /* If the file name has special constructs in it,
3099 call the corresponding file handler. */
3100 handler
= Ffind_file_name_handler (absname1
, Qfile_newer_than_file_p
);
3102 handler
= Ffind_file_name_handler (absname2
, Qfile_newer_than_file_p
);
3103 if (!NILP (handler
))
3104 return call3 (handler
, Qfile_newer_than_file_p
, absname1
, absname2
);
3106 GCPRO2 (absname1
, absname2
);
3107 absname1
= ENCODE_FILE (absname1
);
3108 absname2
= ENCODE_FILE (absname2
);
3111 if (stat (XSTRING (absname1
)->data
, &st
) < 0)
3114 mtime1
= st
.st_mtime
;
3116 if (stat (XSTRING (absname2
)->data
, &st
) < 0)
3119 return (mtime1
> st
.st_mtime
) ? Qt
: Qnil
;
3123 Lisp_Object Qfind_buffer_file_type
;
3126 #ifndef READ_BUF_SIZE
3127 #define READ_BUF_SIZE (64 << 10)
3130 DEFUN ("insert-file-contents", Finsert_file_contents
, Sinsert_file_contents
,
3132 "Insert contents of file FILENAME after point.\n\
3133 Returns list of absolute file name and number of bytes inserted.\n\
3134 If second argument VISIT is non-nil, the buffer's visited filename\n\
3135 and last save file modtime are set, and it is marked unmodified.\n\
3136 If visiting and the file does not exist, visiting is completed\n\
3137 before the error is signaled.\n\
3138 The optional third and fourth arguments BEG and END\n\
3139 specify what portion of the file to insert.\n\
3140 These arguments count bytes in the file, not characters in the buffer.\n\
3141 If VISIT is non-nil, BEG and END must be nil.\n\
3143 If optional fifth argument REPLACE is non-nil,\n\
3144 it means replace the current buffer contents (in the accessible portion)\n\
3145 with the file contents. This is better than simply deleting and inserting\n\
3146 the whole thing because (1) it preserves some marker positions\n\
3147 and (2) it puts less data in the undo list.\n\
3148 When REPLACE is non-nil, the value is the number of characters actually read,\n\
3149 which is often less than the number of characters to be read.\n\
3150 This does code conversion according to the value of\n\
3151 `coding-system-for-read' or `file-coding-system-alist',\n\
3152 and sets the variable `last-coding-system-used' to the coding system\n\
3154 (filename
, visit
, beg
, end
, replace
)
3155 Lisp_Object filename
, visit
, beg
, end
, replace
;
3160 register int how_much
;
3161 register int unprocessed
;
3162 int count
= specpdl_ptr
- specpdl
;
3163 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
3164 Lisp_Object handler
, val
, insval
, orig_filename
;
3167 int not_regular
= 0;
3168 char read_buf
[READ_BUF_SIZE
];
3169 struct coding_system coding
;
3170 unsigned char buffer
[1 << 14];
3171 int replace_handled
= 0;
3172 int set_coding_system
= 0;
3174 if (current_buffer
->base_buffer
&& ! NILP (visit
))
3175 error ("Cannot do file visiting in an indirect buffer");
3177 if (!NILP (current_buffer
->read_only
))
3178 Fbarf_if_buffer_read_only ();
3182 orig_filename
= Qnil
;
3184 GCPRO4 (filename
, val
, p
, orig_filename
);
3186 CHECK_STRING (filename
, 0);
3187 filename
= Fexpand_file_name (filename
, Qnil
);
3189 /* If the file name has special constructs in it,
3190 call the corresponding file handler. */
3191 handler
= Ffind_file_name_handler (filename
, Qinsert_file_contents
);
3192 if (!NILP (handler
))
3194 val
= call6 (handler
, Qinsert_file_contents
, filename
,
3195 visit
, beg
, end
, replace
);
3199 orig_filename
= filename
;
3200 filename
= ENCODE_FILE (filename
);
3205 if (stat (XSTRING (filename
)->data
, &st
) < 0)
3207 if ((fd
= open (XSTRING (filename
)->data
, O_RDONLY
)) < 0
3208 || fstat (fd
, &st
) < 0)
3209 #endif /* not APOLLO */
3211 if (fd
>= 0) close (fd
);
3214 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
3217 if (!NILP (Vcoding_system_for_read
))
3218 current_buffer
->buffer_file_coding_system
= Vcoding_system_for_read
;
3223 /* This code will need to be changed in order to work on named
3224 pipes, and it's probably just not worth it. So we should at
3225 least signal an error. */
3226 if (!S_ISREG (st
.st_mode
))
3233 if (! NILP (replace
) || ! NILP (beg
) || ! NILP (end
))
3234 Fsignal (Qfile_error
,
3235 Fcons (build_string ("not a regular file"),
3236 Fcons (orig_filename
, Qnil
)));
3241 if ((fd
= open (XSTRING (filename
)->data
, O_RDONLY
)) < 0)
3244 /* Replacement should preserve point as it preserves markers. */
3245 if (!NILP (replace
))
3246 record_unwind_protect (restore_point_unwind
, Fpoint_marker ());
3248 record_unwind_protect (close_file_unwind
, make_number (fd
));
3250 /* Supposedly happens on VMS. */
3251 if (! not_regular
&& st
.st_size
< 0)
3252 error ("File size is negative");
3254 if (!NILP (beg
) || !NILP (end
))
3256 error ("Attempt to visit less than an entire file");
3259 CHECK_NUMBER (beg
, 0);
3261 XSETFASTINT (beg
, 0);
3264 CHECK_NUMBER (end
, 0);
3269 XSETINT (end
, st
.st_size
);
3270 if (XINT (end
) != st
.st_size
)
3271 error ("Maximum buffer size exceeded");
3275 /* Decide the coding-system of the file. */
3277 Lisp_Object val
= Qnil
;
3279 if (!NILP (Vcoding_system_for_read
))
3280 val
= Vcoding_system_for_read
;
3283 if (! NILP (Vset_auto_coding_function
))
3285 /* Find a coding system specified in the heading two lines
3286 or in the tailing several lines of the file. We assume
3287 that the 1K-byte and 3K-byte for heading and tailing
3288 respectively are sufficient fot this purpose. */
3289 int how_many
, nread
;
3291 if (st
.st_size
<= (1024 * 4))
3292 nread
= read (fd
, read_buf
, 1024 * 4);
3295 nread
= read (fd
, read_buf
, 1024);
3298 if (lseek (fd
, st
.st_size
- (1024 * 3), 0) < 0)
3299 report_file_error ("Setting file position",
3300 Fcons (orig_filename
, Qnil
));
3301 nread
+= read (fd
, read_buf
+ nread
, 1024 * 3);
3306 error ("IO error reading %s: %s",
3307 XSTRING (orig_filename
)->data
, strerror (errno
));
3311 /* Always make this a unibyte string
3312 because we have not yet decoded it. */
3313 tem
= make_unibyte_string (read_buf
, nread
);
3314 val
= call1 (Vset_auto_coding_function
, tem
);
3315 /* Rewind the file for the actual read done later. */
3316 if (lseek (fd
, 0, 0) < 0)
3317 report_file_error ("Setting file position",
3318 Fcons (orig_filename
, Qnil
));
3323 Lisp_Object args
[6], coding_systems
;
3325 args
[0] = Qinsert_file_contents
, args
[1] = orig_filename
,
3326 args
[2] = visit
, args
[3] = beg
, args
[4] = end
, args
[5] = replace
;
3327 coding_systems
= Ffind_operation_coding_system (6, args
);
3328 if (CONSP (coding_systems
)) val
= XCONS (coding_systems
)->car
;
3332 if (NILP (Vcoding_system_for_read
)
3333 && NILP (current_buffer
->enable_multibyte_characters
))
3335 /* We must suppress all text conversion except for end-of-line
3337 struct coding_system coding_temp
;
3339 setup_coding_system (Fcheck_coding_system (val
), &coding_temp
);
3340 setup_coding_system (Qraw_text
, &coding
);
3341 coding
.eol_type
= coding_temp
.eol_type
;
3344 setup_coding_system (Fcheck_coding_system (val
), &coding
);
3347 /* If requested, replace the accessible part of the buffer
3348 with the file contents. Avoid replacing text at the
3349 beginning or end of the buffer that matches the file contents;
3350 that preserves markers pointing to the unchanged parts.
3352 Here we implement this feature in an optimized way
3353 for the case where code conversion is NOT needed.
3354 The following if-statement handles the case of conversion
3355 in a less optimal way.
3357 If the code conversion is "automatic" then we try using this
3358 method and hope for the best.
3359 But if we discover the need for conversion, we give up on this method
3360 and let the following if-statement handle the replace job. */
3362 && ! CODING_REQUIRE_DECODING (&coding
))
3364 /* same_at_start and same_at_end count bytes,
3365 because file access counts bytes
3366 and BEG and END count bytes. */
3367 int same_at_start
= BEGV_BYTE
;
3368 int same_at_end
= ZV_BYTE
;
3370 /* There is still a possibility we will find the need to do code
3371 conversion. If that happens, we set this variable to 1 to
3372 give up on handling REPLACE in the optimized way. */
3373 int giveup_match_end
= 0;
3375 if (XINT (beg
) != 0)
3377 if (lseek (fd
, XINT (beg
), 0) < 0)
3378 report_file_error ("Setting file position",
3379 Fcons (orig_filename
, Qnil
));
3384 /* Count how many chars at the start of the file
3385 match the text at the beginning of the buffer. */
3390 nread
= read (fd
, buffer
, sizeof buffer
);
3392 error ("IO error reading %s: %s",
3393 XSTRING (orig_filename
)->data
, strerror (errno
));
3394 else if (nread
== 0)
3397 if (coding
.type
== coding_type_undecided
)
3398 detect_coding (&coding
, buffer
, nread
);
3399 if (CODING_REQUIRE_DECODING (&coding
))
3400 /* We found that the file should be decoded somehow.
3401 Let's give up here. */
3403 giveup_match_end
= 1;
3407 if (coding
.eol_type
== CODING_EOL_UNDECIDED
)
3408 detect_eol (&coding
, buffer
, nread
);
3409 if (coding
.eol_type
!= CODING_EOL_UNDECIDED
3410 && coding
.eol_type
!= CODING_EOL_LF
)
3411 /* We found that the format of eol should be decoded.
3412 Let's give up here. */
3414 giveup_match_end
= 1;
3419 while (bufpos
< nread
&& same_at_start
< ZV_BYTE
3420 && FETCH_BYTE (same_at_start
) == buffer
[bufpos
])
3421 same_at_start
++, bufpos
++;
3422 /* If we found a discrepancy, stop the scan.
3423 Otherwise loop around and scan the next bufferful. */
3424 if (bufpos
!= nread
)
3428 /* If the file matches the buffer completely,
3429 there's no need to replace anything. */
3430 if (same_at_start
- BEGV_BYTE
== XINT (end
))
3434 /* Truncate the buffer to the size of the file. */
3435 del_range_1 (same_at_start
, same_at_end
, 0);
3440 /* Count how many chars at the end of the file
3441 match the text at the end of the buffer. But, if we have
3442 already found that decoding is necessary, don't waste time. */
3443 while (!giveup_match_end
)
3445 int total_read
, nread
, bufpos
, curpos
, trial
;
3447 /* At what file position are we now scanning? */
3448 curpos
= XINT (end
) - (ZV_BYTE
- same_at_end
);
3449 /* If the entire file matches the buffer tail, stop the scan. */
3452 /* How much can we scan in the next step? */
3453 trial
= min (curpos
, sizeof buffer
);
3454 if (lseek (fd
, curpos
- trial
, 0) < 0)
3455 report_file_error ("Setting file position",
3456 Fcons (orig_filename
, Qnil
));
3459 while (total_read
< trial
)
3461 nread
= read (fd
, buffer
+ total_read
, trial
- total_read
);
3463 error ("IO error reading %s: %s",
3464 XSTRING (orig_filename
)->data
, strerror (errno
));
3465 total_read
+= nread
;
3467 /* Scan this bufferful from the end, comparing with
3468 the Emacs buffer. */
3469 bufpos
= total_read
;
3470 /* Compare with same_at_start to avoid counting some buffer text
3471 as matching both at the file's beginning and at the end. */
3472 while (bufpos
> 0 && same_at_end
> same_at_start
3473 && FETCH_BYTE (same_at_end
- 1) == buffer
[bufpos
- 1])
3474 same_at_end
--, bufpos
--;
3476 /* If we found a discrepancy, stop the scan.
3477 Otherwise loop around and scan the preceding bufferful. */
3480 /* If this discrepancy is because of code conversion,
3481 we cannot use this method; giveup and try the other. */
3482 if (same_at_end
> same_at_start
3483 && FETCH_BYTE (same_at_end
- 1) >= 0200
3484 && ! NILP (current_buffer
->enable_multibyte_characters
)
3485 && (CODING_MAY_REQUIRE_DECODING (&coding
)))
3486 giveup_match_end
= 1;
3492 if (! giveup_match_end
)
3496 /* We win! We can handle REPLACE the optimized way. */
3498 /* Extends the end of non-matching text area to multibyte
3499 character boundary. */
3500 if (! NILP (current_buffer
->enable_multibyte_characters
))
3501 while (same_at_end
< ZV_BYTE
3502 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_end
)))
3505 /* Don't try to reuse the same piece of text twice. */
3506 overlap
= (same_at_start
- BEGV_BYTE
3507 - (same_at_end
+ st
.st_size
- ZV
));
3509 same_at_end
+= overlap
;
3511 /* Arrange to read only the nonmatching middle part of the file. */
3512 XSETFASTINT (beg
, XINT (beg
) + (same_at_start
- BEGV_BYTE
));
3513 XSETFASTINT (end
, XINT (end
) - (ZV_BYTE
- same_at_end
));
3515 del_range_byte (same_at_start
, same_at_end
, 0);
3516 /* Insert from the file at the proper position. */
3517 temp
= BYTE_TO_CHAR (same_at_start
);
3518 SET_PT_BOTH (temp
, same_at_start
);
3520 /* If display currently starts at beginning of line,
3521 keep it that way. */
3522 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3523 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3525 replace_handled
= 1;
3529 /* If requested, replace the accessible part of the buffer
3530 with the file contents. Avoid replacing text at the
3531 beginning or end of the buffer that matches the file contents;
3532 that preserves markers pointing to the unchanged parts.
3534 Here we implement this feature for the case where code conversion
3535 is needed, in a simple way that needs a lot of memory.
3536 The preceding if-statement handles the case of no conversion
3537 in a more optimized way. */
3538 if (!NILP (replace
) && ! replace_handled
)
3540 int same_at_start
= BEGV_BYTE
;
3541 int same_at_end
= ZV_BYTE
;
3544 /* Make sure that the gap is large enough. */
3545 int bufsize
= 2 * st
.st_size
;
3546 unsigned char *conversion_buffer
= (unsigned char *) xmalloc (bufsize
);
3549 /* First read the whole file, performing code conversion into
3550 CONVERSION_BUFFER. */
3552 if (lseek (fd
, XINT (beg
), 0) < 0)
3554 free (conversion_buffer
);
3555 report_file_error ("Setting file position",
3556 Fcons (orig_filename
, Qnil
));
3559 total
= st
.st_size
; /* Total bytes in the file. */
3560 how_much
= 0; /* Bytes read from file so far. */
3561 inserted
= 0; /* Bytes put into CONVERSION_BUFFER so far. */
3562 unprocessed
= 0; /* Bytes not processed in previous loop. */
3564 while (how_much
< total
)
3566 /* try is reserved in some compilers (Microsoft C) */
3567 int trytry
= min (total
- how_much
, READ_BUF_SIZE
- unprocessed
);
3568 char *destination
= read_buf
+ unprocessed
;
3571 /* Allow quitting out of the actual I/O. */
3574 this = read (fd
, destination
, trytry
);
3577 if (this < 0 || this + unprocessed
== 0)
3585 if (CODING_MAY_REQUIRE_DECODING (&coding
))
3587 int require
, result
;
3589 this += unprocessed
;
3591 /* If we are using more space than estimated,
3592 make CONVERSION_BUFFER bigger. */
3593 require
= decoding_buffer_size (&coding
, this);
3594 if (inserted
+ require
+ 2 * (total
- how_much
) > bufsize
)
3596 bufsize
= inserted
+ require
+ 2 * (total
- how_much
);
3597 conversion_buffer
= (unsigned char *) xrealloc (conversion_buffer
, bufsize
);
3600 /* Convert this batch with results in CONVERSION_BUFFER. */
3601 if (how_much
>= total
) /* This is the last block. */
3602 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
3603 result
= decode_coding (&coding
, read_buf
,
3604 conversion_buffer
+ inserted
,
3605 this, bufsize
- inserted
);
3607 /* Save for next iteration whatever we didn't convert. */
3608 unprocessed
= this - coding
.consumed
;
3609 bcopy (read_buf
+ coding
.consumed
, read_buf
, unprocessed
);
3610 this = coding
.produced
;
3616 /* At this point, INSERTED is how many characters (i.e. bytes)
3617 are present in CONVERSION_BUFFER.
3618 HOW_MUCH should equal TOTAL,
3619 or should be <= 0 if we couldn't read the file. */
3623 free (conversion_buffer
);
3626 error ("IO error reading %s: %s",
3627 XSTRING (orig_filename
)->data
, strerror (errno
));
3628 else if (how_much
== -2)
3629 error ("maximum buffer size exceeded");
3632 /* Compare the beginning of the converted file
3633 with the buffer text. */
3636 while (bufpos
< inserted
&& same_at_start
< same_at_end
3637 && FETCH_BYTE (same_at_start
) == conversion_buffer
[bufpos
])
3638 same_at_start
++, bufpos
++;
3640 /* If the file matches the buffer completely,
3641 there's no need to replace anything. */
3643 if (bufpos
== inserted
)
3645 free (conversion_buffer
);
3648 /* Truncate the buffer to the size of the file. */
3649 del_range_1 (same_at_start
, same_at_end
, 0);
3653 /* Scan this bufferful from the end, comparing with
3654 the Emacs buffer. */
3657 /* Compare with same_at_start to avoid counting some buffer text
3658 as matching both at the file's beginning and at the end. */
3659 while (bufpos
> 0 && same_at_end
> same_at_start
3660 && FETCH_BYTE (same_at_end
- 1) == conversion_buffer
[bufpos
- 1])
3661 same_at_end
--, bufpos
--;
3663 /* Don't try to reuse the same piece of text twice. */
3664 overlap
= same_at_start
- BEGV_BYTE
- (same_at_end
+ inserted
- ZV_BYTE
);
3666 same_at_end
+= overlap
;
3668 /* If display currently starts at beginning of line,
3669 keep it that way. */
3670 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3671 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3673 /* Replace the chars that we need to replace,
3674 and update INSERTED to equal the number of bytes
3675 we are taking from the file. */
3676 inserted
-= (Z_BYTE
- same_at_end
) + (same_at_start
- BEG_BYTE
);
3677 del_range_byte (same_at_start
, same_at_end
, 0);
3678 SET_PT_BOTH (GPT
, GPT_BYTE
);
3680 insert_1 (conversion_buffer
+ same_at_start
- BEG_BYTE
, inserted
,
3683 free (conversion_buffer
);
3692 register Lisp_Object temp
;
3694 total
= XINT (end
) - XINT (beg
);
3696 /* Make sure point-max won't overflow after this insertion. */
3697 XSETINT (temp
, total
);
3698 if (total
!= XINT (temp
))
3699 error ("Maximum buffer size exceeded");
3702 /* For a special file, all we can do is guess. */
3703 total
= READ_BUF_SIZE
;
3705 if (NILP (visit
) && total
> 0)
3706 prepare_to_modify_buffer (PT
, PT
, NULL
);
3709 if (GAP_SIZE
< total
)
3710 make_gap (total
- GAP_SIZE
);
3712 if (XINT (beg
) != 0 || !NILP (replace
))
3714 if (lseek (fd
, XINT (beg
), 0) < 0)
3715 report_file_error ("Setting file position",
3716 Fcons (orig_filename
, Qnil
));
3719 /* In the following loop, HOW_MUCH contains the total bytes read so
3720 far for a regular file, and not changed for a special file. But,
3721 before exiting the loop, it is set to a negative value if I/O
3724 /* Total bytes inserted. */
3726 /* Here, we don't do code conversion in the loop. It is done by
3727 code_convert_region after all data are read into the buffer. */
3728 while (how_much
< total
)
3730 /* try is reserved in some compilers (Microsoft C) */
3731 int trytry
= min (total
- how_much
, READ_BUF_SIZE
);
3734 /* For a special file, GAP_SIZE should be checked every time. */
3735 if (not_regular
&& GAP_SIZE
< trytry
)
3736 make_gap (total
- GAP_SIZE
);
3738 /* Allow quitting out of the actual I/O. */
3741 this = read (fd
, BYTE_POS_ADDR (PT_BYTE
+ inserted
- 1) + 1, trytry
);
3758 /* For a regular file, where TOTAL is the real size,
3759 count HOW_MUCH to compare with it.
3760 For a special file, where TOTAL is just a buffer size,
3761 so don't bother counting in HOW_MUCH.
3762 (INSERTED is where we count the number of characters inserted.) */
3769 /* Put an anchor to ensure multi-byte form ends at gap. */
3774 /* Discard the unwind protect for closing the file. */
3778 error ("IO error reading %s: %s",
3779 XSTRING (orig_filename
)->data
, strerror (errno
));
3783 if (CODING_MAY_REQUIRE_DECODING (&coding
))
3785 /* Here, we don't have to consider byte combining (see the
3786 comment below) because code_convert_region takes care of
3788 code_convert_region (PT
, PT_BYTE
, PT
+ inserted
, PT_BYTE
+ inserted
,
3790 inserted
= (NILP (current_buffer
->enable_multibyte_characters
)
3791 ? coding
.produced
: coding
.produced_char
);
3793 else if (!NILP (current_buffer
->enable_multibyte_characters
))
3795 int inserted_byte
= inserted
;
3797 /* There's a possibility that we must combine bytes at the
3798 head (resp. the tail) of the just inserted text with the
3799 bytes before (resp. after) the gap to form a single
3801 inserted
= multibyte_chars_in_text (GPT_ADDR
- inserted
, inserted
);
3802 adjust_after_insert (PT
, PT_BYTE
,
3803 PT
+ inserted_byte
, PT_BYTE
+ inserted_byte
,
3808 /* Use the conversion type to determine buffer-file-type
3809 (find-buffer-file-type is now used to help determine the
3811 if (coding
.eol_type
!= CODING_EOL_UNDECIDED
3812 && coding
.eol_type
!= CODING_EOL_LF
)
3813 current_buffer
->buffer_file_type
= Qnil
;
3815 current_buffer
->buffer_file_type
= Qt
;
3819 set_coding_system
= 1;
3826 if (!EQ (current_buffer
->undo_list
, Qt
))
3827 current_buffer
->undo_list
= Qnil
;
3829 stat (XSTRING (filename
)->data
, &st
);
3834 current_buffer
->modtime
= st
.st_mtime
;
3835 current_buffer
->filename
= orig_filename
;
3838 SAVE_MODIFF
= MODIFF
;
3839 current_buffer
->auto_save_modified
= MODIFF
;
3840 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
3841 #ifdef CLASH_DETECTION
3844 if (!NILP (current_buffer
->file_truename
))
3845 unlock_file (current_buffer
->file_truename
);
3846 unlock_file (filename
);
3848 #endif /* CLASH_DETECTION */
3850 Fsignal (Qfile_error
,
3851 Fcons (build_string ("not a regular file"),
3852 Fcons (orig_filename
, Qnil
)));
3854 /* If visiting nonexistent file, return nil. */
3855 if (current_buffer
->modtime
== -1)
3856 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
3859 /* Decode file format */
3862 insval
= call3 (Qformat_decode
,
3863 Qnil
, make_number (inserted
), visit
);
3864 CHECK_NUMBER (insval
, 0);
3865 inserted
= XFASTINT (insval
);
3868 /* Call after-change hooks for the inserted text, aside from the case
3869 of normal visiting (not with REPLACE), which is done in a new buffer
3870 "before" the buffer is changed. */
3871 if (inserted
> 0 && total
> 0
3872 && (NILP (visit
) || !NILP (replace
)))
3873 signal_after_change (PT
, 0, inserted
);
3875 if (set_coding_system
)
3876 Vlast_coding_system_used
= coding
.symbol
;
3880 p
= Vafter_insert_file_functions
;
3883 insval
= call1 (Fcar (p
), make_number (inserted
));
3886 CHECK_NUMBER (insval
, 0);
3887 inserted
= XFASTINT (insval
);
3894 /* ??? Retval needs to be dealt with in all cases consistently. */
3896 val
= Fcons (orig_filename
,
3897 Fcons (make_number (inserted
),
3900 RETURN_UNGCPRO (unbind_to (count
, val
));
3903 static Lisp_Object build_annotations
P_ ((Lisp_Object
, Lisp_Object
,
3906 /* If build_annotations switched buffers, switch back to BUF.
3907 Kill the temporary buffer that was selected in the meantime.
3909 Since this kill only the last temporary buffer, some buffers remain
3910 not killed if build_annotations switched buffers more than once.
3914 build_annotations_unwind (buf
)
3919 if (XBUFFER (buf
) == current_buffer
)
3921 tembuf
= Fcurrent_buffer ();
3923 Fkill_buffer (tembuf
);
3927 DEFUN ("write-region", Fwrite_region
, Swrite_region
, 3, 7,
3928 "r\nFWrite region to file: \ni\ni\ni\np",
3929 "Write current region into specified file.\n\
3930 When called from a program, takes three arguments:\n\
3931 START, END and FILENAME. START and END are buffer positions.\n\
3932 Optional fourth argument APPEND if non-nil means\n\
3933 append to existing file contents (if any).\n\
3934 Optional fifth argument VISIT if t means\n\
3935 set the last-save-file-modtime of buffer to this file's modtime\n\
3936 and mark buffer not modified.\n\
3937 If VISIT is a string, it is a second file name;\n\
3938 the output goes to FILENAME, but the buffer is marked as visiting VISIT.\n\
3939 VISIT is also the file name to lock and unlock for clash detection.\n\
3940 If VISIT is neither t nor nil nor a string,\n\
3941 that means do not print the \"Wrote file\" message.\n\
3942 The optional sixth arg LOCKNAME, if non-nil, specifies the name to\n\
3943 use for locking and unlocking, overriding FILENAME and VISIT.\n\
3944 The optional seventh arg CONFIRM, if non-nil, says ask for confirmation\n\
3945 before overwriting an existing file.\n\
3946 Kludgy feature: if START is a string, then that string is written\n\
3947 to the file, instead of any buffer contents, and END is ignored.")
3948 (start
, end
, filename
, append
, visit
, lockname
, confirm
)
3949 Lisp_Object start
, end
, filename
, append
, visit
, lockname
, confirm
;
3957 int count
= specpdl_ptr
- specpdl
;
3960 unsigned char *fname
= 0; /* If non-0, original filename (must rename) */
3962 Lisp_Object handler
;
3963 Lisp_Object visit_file
;
3964 Lisp_Object annotations
;
3965 Lisp_Object encoded_filename
;
3966 int visiting
, quietly
;
3967 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
3968 struct buffer
*given_buffer
;
3970 int buffer_file_type
= O_BINARY
;
3972 struct coding_system coding
;
3974 if (current_buffer
->base_buffer
&& ! NILP (visit
))
3975 error ("Cannot do file visiting in an indirect buffer");
3977 if (!NILP (start
) && !STRINGP (start
))
3978 validate_region (&start
, &end
);
3980 GCPRO4 (start
, filename
, visit
, lockname
);
3982 /* Decide the coding-system to encode the data with. */
3988 else if (!NILP (Vcoding_system_for_write
))
3989 val
= Vcoding_system_for_write
;
3990 else if (NILP (current_buffer
->enable_multibyte_characters
))
3992 /* If the variable `buffer-file-coding-system' is set locally,
3993 it means that the file was read with some kind of code
3994 conversion or the varialbe is explicitely set by users. We
3995 had better write it out with the same coding system even if
3996 `enable-multibyte-characters' is nil.
3998 If it is not set locally, we anyway have to convert EOL
3999 format if the default value of `buffer-file-coding-system'
4000 tells that it is not Unix-like (LF only) format. */
4001 val
= current_buffer
->buffer_file_coding_system
;
4002 if (NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4004 struct coding_system coding_temp
;
4006 setup_coding_system (Fcheck_coding_system (val
), &coding_temp
);
4007 if (coding_temp
.eol_type
== CODING_EOL_CRLF
4008 || coding_temp
.eol_type
== CODING_EOL_CR
)
4010 setup_coding_system (Qraw_text
, &coding
);
4011 coding
.eol_type
= coding_temp
.eol_type
;
4012 goto done_setup_coding
;
4019 Lisp_Object args
[7], coding_systems
;
4021 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4022 args
[3] = filename
; args
[4] = append
; args
[5] = visit
;
4024 coding_systems
= Ffind_operation_coding_system (7, args
);
4025 val
= (CONSP (coding_systems
) && !NILP (XCONS (coding_systems
)->cdr
)
4026 ? XCONS (coding_systems
)->cdr
4027 : current_buffer
->buffer_file_coding_system
);
4028 /* Confirm that VAL can surely encode the current region. */
4029 if (Ffboundp (Vselect_safe_coding_system_function
))
4030 val
= call3 (Vselect_safe_coding_system_function
, start
, end
, val
);
4032 setup_coding_system (Fcheck_coding_system (val
), &coding
);
4035 if (!STRINGP (start
) && !NILP (current_buffer
->selective_display
))
4036 coding
.mode
|= CODING_MODE_SELECTIVE_DISPLAY
;
4039 Vlast_coding_system_used
= coding
.symbol
;
4041 filename
= Fexpand_file_name (filename
, Qnil
);
4043 if (! NILP (confirm
))
4044 barf_or_query_if_file_exists (filename
, "overwrite", 1, 0, 1);
4046 if (STRINGP (visit
))
4047 visit_file
= Fexpand_file_name (visit
, Qnil
);
4049 visit_file
= filename
;
4052 visiting
= (EQ (visit
, Qt
) || STRINGP (visit
));
4053 quietly
= !NILP (visit
);
4057 if (NILP (lockname
))
4058 lockname
= visit_file
;
4060 GCPRO5 (start
, filename
, annotations
, visit_file
, lockname
);
4062 /* If the file name has special constructs in it,
4063 call the corresponding file handler. */
4064 handler
= Ffind_file_name_handler (filename
, Qwrite_region
);
4065 /* If FILENAME has no handler, see if VISIT has one. */
4066 if (NILP (handler
) && STRINGP (visit
))
4067 handler
= Ffind_file_name_handler (visit
, Qwrite_region
);
4069 if (!NILP (handler
))
4072 val
= call6 (handler
, Qwrite_region
, start
, end
,
4073 filename
, append
, visit
);
4077 SAVE_MODIFF
= MODIFF
;
4078 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4079 current_buffer
->filename
= visit_file
;
4085 /* Special kludge to simplify auto-saving. */
4088 XSETFASTINT (start
, BEG
);
4089 XSETFASTINT (end
, Z
);
4092 record_unwind_protect (build_annotations_unwind
, Fcurrent_buffer ());
4093 count1
= specpdl_ptr
- specpdl
;
4095 given_buffer
= current_buffer
;
4096 annotations
= build_annotations (start
, end
, coding
.pre_write_conversion
);
4097 if (current_buffer
!= given_buffer
)
4099 XSETFASTINT (start
, BEGV
);
4100 XSETFASTINT (end
, ZV
);
4103 #ifdef CLASH_DETECTION
4106 #if 0 /* This causes trouble for GNUS. */
4107 /* If we've locked this file for some other buffer,
4108 query before proceeding. */
4109 if (!visiting
&& EQ (Ffile_locked_p (lockname
), Qt
))
4110 call2 (intern ("ask-user-about-lock"), filename
, Vuser_login_name
);
4113 lock_file (lockname
);
4115 #endif /* CLASH_DETECTION */
4117 encoded_filename
= ENCODE_FILE (filename
);
4119 fn
= XSTRING (encoded_filename
)->data
;
4123 desc
= open (fn
, O_WRONLY
| buffer_file_type
);
4124 #else /* not DOS_NT */
4125 desc
= open (fn
, O_WRONLY
);
4126 #endif /* not DOS_NT */
4128 if (desc
< 0 && (NILP (append
) || errno
== ENOENT
))
4130 if (auto_saving
) /* Overwrite any previous version of autosave file */
4132 vms_truncate (fn
); /* if fn exists, truncate to zero length */
4133 desc
= open (fn
, O_RDWR
);
4135 desc
= creat_copy_attrs (STRINGP (current_buffer
->filename
)
4136 ? XSTRING (current_buffer
->filename
)->data
: 0,
4139 else /* Write to temporary name and rename if no errors */
4141 Lisp_Object temp_name
;
4142 temp_name
= Ffile_name_directory (filename
);
4144 if (!NILP (temp_name
))
4146 temp_name
= Fmake_temp_name (concat2 (temp_name
,
4147 build_string ("$$SAVE$$")));
4148 fname
= XSTRING (filename
)->data
;
4149 fn
= XSTRING (temp_name
)->data
;
4150 desc
= creat_copy_attrs (fname
, fn
);
4153 /* If we can't open the temporary file, try creating a new
4154 version of the original file. VMS "creat" creates a
4155 new version rather than truncating an existing file. */
4158 desc
= creat (fn
, 0666);
4159 #if 0 /* This can clobber an existing file and fail to replace it,
4160 if the user runs out of space. */
4163 /* We can't make a new version;
4164 try to truncate and rewrite existing version if any. */
4166 desc
= open (fn
, O_RDWR
);
4172 desc
= creat (fn
, 0666);
4177 O_WRONLY
| O_TRUNC
| O_CREAT
| buffer_file_type
,
4178 S_IREAD
| S_IWRITE
);
4179 #else /* not DOS_NT */
4180 desc
= creat (fn
, auto_saving
? auto_save_mode_bits
: 0666);
4181 #endif /* not DOS_NT */
4182 #endif /* not VMS */
4188 #ifdef CLASH_DETECTION
4190 if (!auto_saving
) unlock_file (lockname
);
4192 #endif /* CLASH_DETECTION */
4193 report_file_error ("Opening output file", Fcons (filename
, Qnil
));
4196 record_unwind_protect (close_file_unwind
, make_number (desc
));
4199 if (lseek (desc
, 0, 2) < 0)
4201 #ifdef CLASH_DETECTION
4202 if (!auto_saving
) unlock_file (lockname
);
4203 #endif /* CLASH_DETECTION */
4204 report_file_error ("Lseek error", Fcons (filename
, Qnil
));
4209 * Kludge Warning: The VMS C RTL likes to insert carriage returns
4210 * if we do writes that don't end with a carriage return. Furthermore
4211 * it cannot handle writes of more then 16K. The modified
4212 * version of "sys_write" in SYSDEP.C (see comment there) copes with
4213 * this EXCEPT for the last record (iff it doesn't end with a carriage
4214 * return). This implies that if your buffer doesn't end with a carriage
4215 * return, you get one free... tough. However it also means that if
4216 * we make two calls to sys_write (a la the following code) you can
4217 * get one at the gap as well. The easiest way to fix this (honest)
4218 * is to move the gap to the next newline (or the end of the buffer).
4223 if (GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4224 move_gap (find_next_newline (GPT
, 1));
4226 /* Whether VMS or not, we must move the gap to the next of newline
4227 when we must put designation sequences at beginning of line. */
4228 if (INTEGERP (start
)
4229 && coding
.type
== coding_type_iso2022
4230 && coding
.flags
& CODING_FLAG_ISO_DESIGNATE_AT_BOL
4231 && GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4233 int opoint
= PT
, opoint_byte
= PT_BYTE
;
4234 scan_newline (PT
, PT_BYTE
, ZV
, ZV_BYTE
, 1, 0);
4235 move_gap_both (PT
, PT_BYTE
);
4236 SET_PT_BOTH (opoint
, opoint_byte
);
4243 if (STRINGP (start
))
4245 failure
= 0 > a_write (desc
, XSTRING (start
)->data
,
4246 STRING_BYTES (XSTRING (start
)), 0, &annotations
,
4250 else if (XINT (start
) != XINT (end
))
4252 register int end1
= CHAR_TO_BYTE (XINT (end
));
4254 tem
= CHAR_TO_BYTE (XINT (start
));
4256 if (XINT (start
) < GPT
)
4258 failure
= 0 > a_write (desc
, BYTE_POS_ADDR (tem
),
4259 min (GPT_BYTE
, end1
) - tem
, tem
, &annotations
,
4264 if (XINT (end
) > GPT
&& !failure
)
4266 tem
= max (tem
, GPT_BYTE
);
4267 failure
= 0 > a_write (desc
, BYTE_POS_ADDR (tem
), end1
- tem
,
4268 tem
, &annotations
, &coding
);
4274 /* If file was empty, still need to write the annotations */
4275 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4276 failure
= 0 > a_write (desc
, "", 0, XINT (start
), &annotations
, &coding
);
4280 if (CODING_REQUIRE_FLUSHING (&coding
)
4281 && !(coding
.mode
& CODING_MODE_LAST_BLOCK
)
4284 /* We have to flush out a data. */
4285 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4286 failure
= 0 > e_write (desc
, "", 0, &coding
);
4293 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
4294 Disk full in NFS may be reported here. */
4295 /* mib says that closing the file will try to write as fast as NFS can do
4296 it, and that means the fsync here is not crucial for autosave files. */
4297 if (!auto_saving
&& fsync (desc
) < 0)
4299 /* If fsync fails with EINTR, don't treat that as serious. */
4301 failure
= 1, save_errno
= errno
;
4305 /* Spurious "file has changed on disk" warnings have been
4306 observed on Suns as well.
4307 It seems that `close' can change the modtime, under nfs.
4309 (This has supposedly been fixed in Sunos 4,
4310 but who knows about all the other machines with NFS?) */
4313 /* On VMS and APOLLO, must do the stat after the close
4314 since closing changes the modtime. */
4317 /* Recall that #if defined does not work on VMS. */
4324 /* NFS can report a write failure now. */
4325 if (close (desc
) < 0)
4326 failure
= 1, save_errno
= errno
;
4329 /* If we wrote to a temporary name and had no errors, rename to real name. */
4333 failure
= (rename (fn
, fname
) != 0), save_errno
= errno
;
4341 /* Discard the unwind protect for close_file_unwind. */
4342 specpdl_ptr
= specpdl
+ count1
;
4343 /* Restore the original current buffer. */
4344 visit_file
= unbind_to (count
, visit_file
);
4346 #ifdef CLASH_DETECTION
4348 unlock_file (lockname
);
4349 #endif /* CLASH_DETECTION */
4351 /* Do this before reporting IO error
4352 to avoid a "file has changed on disk" warning on
4353 next attempt to save. */
4355 current_buffer
->modtime
= st
.st_mtime
;
4358 error ("IO error writing %s: %s", XSTRING (filename
)->data
,
4359 strerror (save_errno
));
4363 SAVE_MODIFF
= MODIFF
;
4364 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4365 current_buffer
->filename
= visit_file
;
4366 update_mode_lines
++;
4372 message_with_string ("Wrote %s", visit_file
, 1);
4377 Lisp_Object
merge ();
4379 DEFUN ("car-less-than-car", Fcar_less_than_car
, Scar_less_than_car
, 2, 2, 0,
4380 "Return t if (car A) is numerically less than (car B).")
4384 return Flss (Fcar (a
), Fcar (b
));
4387 /* Build the complete list of annotations appropriate for writing out
4388 the text between START and END, by calling all the functions in
4389 write-region-annotate-functions and merging the lists they return.
4390 If one of these functions switches to a different buffer, we assume
4391 that buffer contains altered text. Therefore, the caller must
4392 make sure to restore the current buffer in all cases,
4393 as save-excursion would do. */
4396 build_annotations (start
, end
, pre_write_conversion
)
4397 Lisp_Object start
, end
, pre_write_conversion
;
4399 Lisp_Object annotations
;
4401 struct gcpro gcpro1
, gcpro2
;
4402 Lisp_Object original_buffer
;
4404 XSETBUFFER (original_buffer
, current_buffer
);
4407 p
= Vwrite_region_annotate_functions
;
4408 GCPRO2 (annotations
, p
);
4411 struct buffer
*given_buffer
= current_buffer
;
4412 Vwrite_region_annotations_so_far
= annotations
;
4413 res
= call2 (Fcar (p
), start
, end
);
4414 /* If the function makes a different buffer current,
4415 assume that means this buffer contains altered text to be output.
4416 Reset START and END from the buffer bounds
4417 and discard all previous annotations because they should have
4418 been dealt with by this function. */
4419 if (current_buffer
!= given_buffer
)
4421 XSETFASTINT (start
, BEGV
);
4422 XSETFASTINT (end
, ZV
);
4425 Flength (res
); /* Check basic validity of return value */
4426 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
4430 /* Now do the same for annotation functions implied by the file-format */
4431 if (auto_saving
&& (!EQ (Vauto_save_file_format
, Qt
)))
4432 p
= Vauto_save_file_format
;
4434 p
= current_buffer
->file_format
;
4437 struct buffer
*given_buffer
= current_buffer
;
4438 Vwrite_region_annotations_so_far
= annotations
;
4439 res
= call4 (Qformat_annotate_function
, Fcar (p
), start
, end
,
4441 if (current_buffer
!= given_buffer
)
4443 XSETFASTINT (start
, BEGV
);
4444 XSETFASTINT (end
, ZV
);
4448 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
4452 /* At last, do the same for the function PRE_WRITE_CONVERSION
4453 implied by the current coding-system. */
4454 if (!NILP (pre_write_conversion
))
4456 struct buffer
*given_buffer
= current_buffer
;
4457 Vwrite_region_annotations_so_far
= annotations
;
4458 res
= call2 (pre_write_conversion
, start
, end
);
4460 annotations
= (current_buffer
!= given_buffer
4462 : merge (annotations
, res
, Qcar_less_than_car
));
4469 /* Write to descriptor DESC the NBYTES bytes starting at ADDR,
4470 assuming they start at byte position BYTEPOS in the buffer.
4471 Intersperse with them the annotations from *ANNOT
4472 which fall within the range of byte positions BYTEPOS to BYTEPOS + NBYTES,
4473 each at its appropriate position.
4475 We modify *ANNOT by discarding elements as we use them up.
4477 The return value is negative in case of system call failure. */
4480 a_write (desc
, addr
, nbytes
, bytepos
, annot
, coding
)
4482 register char *addr
;
4483 register int nbytes
;
4486 struct coding_system
*coding
;
4490 int lastpos
= bytepos
+ nbytes
;
4492 while (NILP (*annot
) || CONSP (*annot
))
4494 tem
= Fcar_safe (Fcar (*annot
));
4495 nextpos
= bytepos
- 1;
4497 nextpos
= CHAR_TO_BYTE (XFASTINT (tem
));
4499 /* If there are no more annotations in this range,
4500 output the rest of the range all at once. */
4501 if (! (nextpos
>= bytepos
&& nextpos
<= lastpos
))
4502 return e_write (desc
, addr
, lastpos
- bytepos
, coding
);
4504 /* Output buffer text up to the next annotation's position. */
4505 if (nextpos
> bytepos
)
4507 if (0 > e_write (desc
, addr
, nextpos
- bytepos
, coding
))
4509 addr
+= nextpos
- bytepos
;
4512 /* Output the annotation. */
4513 tem
= Fcdr (Fcar (*annot
));
4516 if (0 > e_write (desc
, XSTRING (tem
)->data
, STRING_BYTES (XSTRING (tem
)),
4520 *annot
= Fcdr (*annot
);
4524 #ifndef WRITE_BUF_SIZE
4525 #define WRITE_BUF_SIZE (16 * 1024)
4528 /* Write NBYTES bytes starting at ADDR into descriptor DESC,
4529 encoding them with coding system CODING. */
4532 e_write (desc
, addr
, nbytes
, coding
)
4534 register char *addr
;
4535 register int nbytes
;
4536 struct coding_system
*coding
;
4538 char buf
[WRITE_BUF_SIZE
];
4540 /* We used to have a code for handling selective display here. But,
4541 now it is handled within encode_coding. */
4544 encode_coding (coding
, addr
, buf
, nbytes
, WRITE_BUF_SIZE
);
4545 nbytes
-= coding
->consumed
, addr
+= coding
->consumed
;
4546 if (coding
->produced
> 0)
4548 coding
->produced
-= write (desc
, buf
, coding
->produced
);
4549 if (coding
->produced
) return -1;
4557 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime
,
4558 Sverify_visited_file_modtime
, 1, 1, 0,
4559 "Return t if last mod time of BUF's visited file matches what BUF records.\n\
4560 This means that the file has not been changed since it was visited or saved.")
4566 Lisp_Object handler
;
4567 Lisp_Object filename
;
4569 CHECK_BUFFER (buf
, 0);
4572 if (!STRINGP (b
->filename
)) return Qt
;
4573 if (b
->modtime
== 0) return Qt
;
4575 /* If the file name has special constructs in it,
4576 call the corresponding file handler. */
4577 handler
= Ffind_file_name_handler (b
->filename
,
4578 Qverify_visited_file_modtime
);
4579 if (!NILP (handler
))
4580 return call2 (handler
, Qverify_visited_file_modtime
, buf
);
4582 filename
= ENCODE_FILE (b
->filename
);
4584 if (stat (XSTRING (filename
)->data
, &st
) < 0)
4586 /* If the file doesn't exist now and didn't exist before,
4587 we say that it isn't modified, provided the error is a tame one. */
4588 if (errno
== ENOENT
|| errno
== EACCES
|| errno
== ENOTDIR
)
4593 if (st
.st_mtime
== b
->modtime
4594 /* If both are positive, accept them if they are off by one second. */
4595 || (st
.st_mtime
> 0 && b
->modtime
> 0
4596 && (st
.st_mtime
== b
->modtime
+ 1
4597 || st
.st_mtime
== b
->modtime
- 1)))
4602 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime
,
4603 Sclear_visited_file_modtime
, 0, 0, 0,
4604 "Clear out records of last mod time of visited file.\n\
4605 Next attempt to save will certainly not complain of a discrepancy.")
4608 current_buffer
->modtime
= 0;
4612 DEFUN ("visited-file-modtime", Fvisited_file_modtime
,
4613 Svisited_file_modtime
, 0, 0, 0,
4614 "Return the current buffer's recorded visited file modification time.\n\
4615 The value is a list of the form (HIGH . LOW), like the time values\n\
4616 that `file-attributes' returns.")
4619 return long_to_cons ((unsigned long) current_buffer
->modtime
);
4622 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime
,
4623 Sset_visited_file_modtime
, 0, 1, 0,
4624 "Update buffer's recorded modification time from the visited file's time.\n\
4625 Useful if the buffer was not read from the file normally\n\
4626 or if the file itself has been changed for some known benign reason.\n\
4627 An argument specifies the modification time value to use\n\
4628 \(instead of that of the visited file), in the form of a list\n\
4629 \(HIGH . LOW) or (HIGH LOW).")
4631 Lisp_Object time_list
;
4633 if (!NILP (time_list
))
4634 current_buffer
->modtime
= cons_to_long (time_list
);
4637 register Lisp_Object filename
;
4639 Lisp_Object handler
;
4641 filename
= Fexpand_file_name (current_buffer
->filename
, Qnil
);
4643 /* If the file name has special constructs in it,
4644 call the corresponding file handler. */
4645 handler
= Ffind_file_name_handler (filename
, Qset_visited_file_modtime
);
4646 if (!NILP (handler
))
4647 /* The handler can find the file name the same way we did. */
4648 return call2 (handler
, Qset_visited_file_modtime
, Qnil
);
4650 filename
= ENCODE_FILE (filename
);
4652 if (stat (XSTRING (filename
)->data
, &st
) >= 0)
4653 current_buffer
->modtime
= st
.st_mtime
;
4663 message_with_string ("Autosaving...error for %s", current_buffer
->name
, 1);
4664 Fsleep_for (make_number (1), Qnil
);
4665 message_with_string ("Autosaving...error for %s", current_buffer
->name
, 0);
4666 Fsleep_for (make_number (1), Qnil
);
4667 message_with_string ("Autosaving...error for %s", current_buffer
->name
, 0);
4668 Fsleep_for (make_number (1), Qnil
);
4678 /* Get visited file's mode to become the auto save file's mode. */
4679 if (stat (XSTRING (current_buffer
->filename
)->data
, &st
) >= 0)
4680 /* But make sure we can overwrite it later! */
4681 auto_save_mode_bits
= st
.st_mode
| 0600;
4683 auto_save_mode_bits
= 0666;
4686 Fwrite_region (Qnil
, Qnil
,
4687 current_buffer
->auto_save_file_name
,
4688 Qnil
, Qlambda
, Qnil
, Qnil
);
4692 do_auto_save_unwind (stream
) /* used as unwind-protect function */
4697 fclose ((FILE *) (XFASTINT (XCONS (stream
)->car
) << 16
4698 | XFASTINT (XCONS (stream
)->cdr
)));
4703 do_auto_save_unwind_1 (value
) /* used as unwind-protect function */
4706 minibuffer_auto_raise
= XINT (value
);
4710 DEFUN ("do-auto-save", Fdo_auto_save
, Sdo_auto_save
, 0, 2, "",
4711 "Auto-save all buffers that need it.\n\
4712 This is all buffers that have auto-saving enabled\n\
4713 and are changed since last auto-saved.\n\
4714 Auto-saving writes the buffer into a file\n\
4715 so that your editing is not lost if the system crashes.\n\
4716 This file is not the file you visited; that changes only when you save.\n\
4717 Normally we run the normal hook `auto-save-hook' before saving.\n\n\
4718 A non-nil NO-MESSAGE argument means do not print any message if successful.\n\
4719 A non-nil CURRENT-ONLY argument means save only current buffer.")
4720 (no_message
, current_only
)
4721 Lisp_Object no_message
, current_only
;
4723 struct buffer
*old
= current_buffer
, *b
;
4724 Lisp_Object tail
, buf
;
4726 char *omessage
= echo_area_glyphs
;
4727 int omessage_length
= echo_area_glyphs_length
;
4728 int oldmultibyte
= message_enable_multibyte
;
4729 int do_handled_files
;
4732 Lisp_Object lispstream
;
4733 int count
= specpdl_ptr
- specpdl
;
4735 int orig_minibuffer_auto_raise
= minibuffer_auto_raise
;
4737 /* Ordinarily don't quit within this function,
4738 but don't make it impossible to quit (in case we get hung in I/O). */
4742 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
4743 point to non-strings reached from Vbuffer_alist. */
4748 if (!NILP (Vrun_hooks
))
4749 call1 (Vrun_hooks
, intern ("auto-save-hook"));
4751 if (STRINGP (Vauto_save_list_file_name
))
4753 Lisp_Object listfile
;
4754 listfile
= Fexpand_file_name (Vauto_save_list_file_name
, Qnil
);
4755 stream
= fopen (XSTRING (listfile
)->data
, "w");
4758 /* Arrange to close that file whether or not we get an error.
4759 Also reset auto_saving to 0. */
4760 lispstream
= Fcons (Qnil
, Qnil
);
4761 XSETFASTINT (XCONS (lispstream
)->car
, (EMACS_UINT
)stream
>> 16);
4762 XSETFASTINT (XCONS (lispstream
)->cdr
, (EMACS_UINT
)stream
& 0xffff);
4773 record_unwind_protect (do_auto_save_unwind
, lispstream
);
4774 record_unwind_protect (do_auto_save_unwind_1
,
4775 make_number (minibuffer_auto_raise
));
4776 minibuffer_auto_raise
= 0;
4779 /* First, save all files which don't have handlers. If Emacs is
4780 crashing, the handlers may tweak what is causing Emacs to crash
4781 in the first place, and it would be a shame if Emacs failed to
4782 autosave perfectly ordinary files because it couldn't handle some
4784 for (do_handled_files
= 0; do_handled_files
< 2; do_handled_files
++)
4785 for (tail
= Vbuffer_alist
; GC_CONSP (tail
); tail
= XCONS (tail
)->cdr
)
4787 buf
= XCONS (XCONS (tail
)->car
)->cdr
;
4790 /* Record all the buffers that have auto save mode
4791 in the special file that lists them. For each of these buffers,
4792 Record visited name (if any) and auto save name. */
4793 if (STRINGP (b
->auto_save_file_name
)
4794 && stream
!= NULL
&& do_handled_files
== 0)
4796 if (!NILP (b
->filename
))
4798 fwrite (XSTRING (b
->filename
)->data
, 1,
4799 STRING_BYTES (XSTRING (b
->filename
)), stream
);
4801 putc ('\n', stream
);
4802 fwrite (XSTRING (b
->auto_save_file_name
)->data
, 1,
4803 STRING_BYTES (XSTRING (b
->auto_save_file_name
)), stream
);
4804 putc ('\n', stream
);
4807 if (!NILP (current_only
)
4808 && b
!= current_buffer
)
4811 /* Don't auto-save indirect buffers.
4812 The base buffer takes care of it. */
4816 /* Check for auto save enabled
4817 and file changed since last auto save
4818 and file changed since last real save. */
4819 if (STRINGP (b
->auto_save_file_name
)
4820 && BUF_SAVE_MODIFF (b
) < BUF_MODIFF (b
)
4821 && b
->auto_save_modified
< BUF_MODIFF (b
)
4822 /* -1 means we've turned off autosaving for a while--see below. */
4823 && XINT (b
->save_length
) >= 0
4824 && (do_handled_files
4825 || NILP (Ffind_file_name_handler (b
->auto_save_file_name
,
4828 EMACS_TIME before_time
, after_time
;
4830 EMACS_GET_TIME (before_time
);
4832 /* If we had a failure, don't try again for 20 minutes. */
4833 if (b
->auto_save_failure_time
>= 0
4834 && EMACS_SECS (before_time
) - b
->auto_save_failure_time
< 1200)
4837 if ((XFASTINT (b
->save_length
) * 10
4838 > (BUF_Z (b
) - BUF_BEG (b
)) * 13)
4839 /* A short file is likely to change a large fraction;
4840 spare the user annoying messages. */
4841 && XFASTINT (b
->save_length
) > 5000
4842 /* These messages are frequent and annoying for `*mail*'. */
4843 && !EQ (b
->filename
, Qnil
)
4844 && NILP (no_message
))
4846 /* It has shrunk too much; turn off auto-saving here. */
4847 minibuffer_auto_raise
= orig_minibuffer_auto_raise
;
4848 message_with_string ("Buffer %s has shrunk a lot; auto save turned off there",
4850 minibuffer_auto_raise
= 0;
4851 /* Turn off auto-saving until there's a real save,
4852 and prevent any more warnings. */
4853 XSETINT (b
->save_length
, -1);
4854 Fsleep_for (make_number (1), Qnil
);
4857 set_buffer_internal (b
);
4858 if (!auto_saved
&& NILP (no_message
))
4859 message1 ("Auto-saving...");
4860 internal_condition_case (auto_save_1
, Qt
, auto_save_error
);
4862 b
->auto_save_modified
= BUF_MODIFF (b
);
4863 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4864 set_buffer_internal (old
);
4866 EMACS_GET_TIME (after_time
);
4868 /* If auto-save took more than 60 seconds,
4869 assume it was an NFS failure that got a timeout. */
4870 if (EMACS_SECS (after_time
) - EMACS_SECS (before_time
) > 60)
4871 b
->auto_save_failure_time
= EMACS_SECS (after_time
);
4875 /* Prevent another auto save till enough input events come in. */
4876 record_auto_save ();
4878 if (auto_saved
&& NILP (no_message
))
4882 sit_for (1, 0, 0, 0, 0);
4883 message2 (omessage
, omessage_length
, oldmultibyte
);
4886 message1 ("Auto-saving...done");
4891 unbind_to (count
, Qnil
);
4895 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved
,
4896 Sset_buffer_auto_saved
, 0, 0, 0,
4897 "Mark current buffer as auto-saved with its current text.\n\
4898 No auto-save file will be written until the buffer changes again.")
4901 current_buffer
->auto_save_modified
= MODIFF
;
4902 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4903 current_buffer
->auto_save_failure_time
= -1;
4907 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure
,
4908 Sclear_buffer_auto_save_failure
, 0, 0, 0,
4909 "Clear any record of a recent auto-save failure in the current buffer.")
4912 current_buffer
->auto_save_failure_time
= -1;
4916 DEFUN ("recent-auto-save-p", Frecent_auto_save_p
, Srecent_auto_save_p
,
4918 "Return t if buffer has been auto-saved since last read in or saved.")
4921 return (SAVE_MODIFF
< current_buffer
->auto_save_modified
) ? Qt
: Qnil
;
4924 /* Reading and completing file names */
4925 extern Lisp_Object
Ffile_name_completion (), Ffile_name_all_completions ();
4927 /* In the string VAL, change each $ to $$ and return the result. */
4930 double_dollars (val
)
4933 register unsigned char *old
, *new;
4937 osize
= STRING_BYTES (XSTRING (val
));
4939 /* Count the number of $ characters. */
4940 for (n
= osize
, count
= 0, old
= XSTRING (val
)->data
; n
> 0; n
--)
4941 if (*old
++ == '$') count
++;
4944 old
= XSTRING (val
)->data
;
4945 val
= make_uninit_multibyte_string (XSTRING (val
)->size
+ count
,
4947 new = XSTRING (val
)->data
;
4948 for (n
= osize
; n
> 0; n
--)
4961 DEFUN ("read-file-name-internal", Fread_file_name_internal
, Sread_file_name_internal
,
4963 "Internal subroutine for read-file-name. Do not call this.")
4964 (string
, dir
, action
)
4965 Lisp_Object string
, dir
, action
;
4966 /* action is nil for complete, t for return list of completions,
4967 lambda for verify final value */
4969 Lisp_Object name
, specdir
, realdir
, val
, orig_string
;
4971 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
4973 CHECK_STRING (string
, 0);
4980 /* No need to protect ACTION--we only compare it with t and nil. */
4981 GCPRO5 (string
, realdir
, name
, specdir
, orig_string
);
4983 if (XSTRING (string
)->size
== 0)
4985 if (EQ (action
, Qlambda
))
4993 orig_string
= string
;
4994 string
= Fsubstitute_in_file_name (string
);
4995 changed
= NILP (Fstring_equal (string
, orig_string
));
4996 name
= Ffile_name_nondirectory (string
);
4997 val
= Ffile_name_directory (string
);
4999 realdir
= Fexpand_file_name (val
, realdir
);
5004 specdir
= Ffile_name_directory (string
);
5005 val
= Ffile_name_completion (name
, realdir
);
5010 return double_dollars (string
);
5014 if (!NILP (specdir
))
5015 val
= concat2 (specdir
, val
);
5017 return double_dollars (val
);
5020 #endif /* not VMS */
5024 if (EQ (action
, Qt
))
5025 return Ffile_name_all_completions (name
, realdir
);
5026 /* Only other case actually used is ACTION = lambda */
5028 /* Supposedly this helps commands such as `cd' that read directory names,
5029 but can someone explain how it helps them? -- RMS */
5030 if (XSTRING (name
)->size
== 0)
5033 return Ffile_exists_p (string
);
5036 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
5037 "Read file name, prompting with PROMPT and completing in directory DIR.\n\
5038 Value is not expanded---you must call `expand-file-name' yourself.\n\
5039 Default name to DEFAULT-FILENAME if user enters a null string.\n\
5040 (If DEFAULT-FILENAME is omitted, the visited file name is used,\n\
5041 except that if INITIAL is specified, that combined with DIR is used.)\n\
5042 Fourth arg MUSTMATCH non-nil means require existing file's name.\n\
5043 Non-nil and non-t means also require confirmation after completion.\n\
5044 Fifth arg INITIAL specifies text to start with.\n\
5045 DIR defaults to current buffer's directory default.")
5046 (prompt
, dir
, default_filename
, mustmatch
, initial
)
5047 Lisp_Object prompt
, dir
, default_filename
, mustmatch
, initial
;
5049 Lisp_Object val
, insdef
, insdef1
, tem
;
5050 struct gcpro gcpro1
, gcpro2
;
5051 register char *homedir
;
5052 int replace_in_history
= 0;
5053 int add_to_history
= 0;
5057 dir
= current_buffer
->directory
;
5058 if (NILP (default_filename
))
5060 if (! NILP (initial
))
5061 default_filename
= Fexpand_file_name (initial
, dir
);
5063 default_filename
= current_buffer
->filename
;
5066 /* If dir starts with user's homedir, change that to ~. */
5067 homedir
= (char *) egetenv ("HOME");
5069 homedir
= strcpy (alloca (strlen (homedir
) + 1), homedir
);
5070 CORRECT_DIR_SEPS (homedir
);
5074 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
5075 && IS_DIRECTORY_SEP (XSTRING (dir
)->data
[strlen (homedir
)]))
5077 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
5078 STRING_BYTES (XSTRING (dir
)) - strlen (homedir
) + 1);
5079 XSTRING (dir
)->data
[0] = '~';
5082 if (insert_default_directory
&& STRINGP (dir
))
5085 if (!NILP (initial
))
5087 Lisp_Object args
[2], pos
;
5091 insdef
= Fconcat (2, args
);
5092 pos
= make_number (XSTRING (double_dollars (dir
))->size
);
5093 insdef1
= Fcons (double_dollars (insdef
), pos
);
5096 insdef1
= double_dollars (insdef
);
5098 else if (STRINGP (initial
))
5101 insdef1
= Fcons (double_dollars (insdef
), make_number (0));
5104 insdef
= Qnil
, insdef1
= Qnil
;
5107 count
= specpdl_ptr
- specpdl
;
5108 specbind (intern ("completion-ignore-case"), Qt
);
5111 GCPRO2 (insdef
, default_filename
);
5112 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
5113 dir
, mustmatch
, insdef1
,
5114 Qfile_name_history
, default_filename
, Qnil
);
5116 tem
= Fsymbol_value (Qfile_name_history
);
5117 if (CONSP (tem
) && EQ (XCONS (tem
)->car
, val
))
5118 replace_in_history
= 1;
5120 /* If Fcompleting_read returned the inserted default string itself
5121 (rather than a new string with the same contents),
5122 it has to mean that the user typed RET with the minibuffer empty.
5123 In that case, we really want to return ""
5124 so that commands such as set-visited-file-name can distinguish. */
5125 if (EQ (val
, default_filename
))
5127 /* In this case, Fcompleting_read has not added an element
5128 to the history. Maybe we should. */
5129 if (! replace_in_history
)
5132 val
= build_string ("");
5136 unbind_to (count
, Qnil
);
5141 error ("No file name specified");
5143 tem
= Fstring_equal (val
, insdef
);
5145 if (!NILP (tem
) && !NILP (default_filename
))
5146 val
= default_filename
;
5147 else if (XSTRING (val
)->size
== 0 && NILP (insdef
))
5149 if (!NILP (default_filename
))
5150 val
= default_filename
;
5152 error ("No default file name");
5154 val
= Fsubstitute_in_file_name (val
);
5156 if (replace_in_history
)
5157 /* Replace what Fcompleting_read added to the history
5158 with what we will actually return. */
5159 XCONS (Fsymbol_value (Qfile_name_history
))->car
= val
;
5160 else if (add_to_history
)
5162 /* Add the value to the history--but not if it matches
5163 the last value already there. */
5164 tem
= Fsymbol_value (Qfile_name_history
);
5165 if (! CONSP (tem
) || NILP (Fequal (XCONS (tem
)->car
, val
)))
5166 Fset (Qfile_name_history
,
5174 Qexpand_file_name
= intern ("expand-file-name");
5175 Qsubstitute_in_file_name
= intern ("substitute-in-file-name");
5176 Qdirectory_file_name
= intern ("directory-file-name");
5177 Qfile_name_directory
= intern ("file-name-directory");
5178 Qfile_name_nondirectory
= intern ("file-name-nondirectory");
5179 Qunhandled_file_name_directory
= intern ("unhandled-file-name-directory");
5180 Qfile_name_as_directory
= intern ("file-name-as-directory");
5181 Qcopy_file
= intern ("copy-file");
5182 Qmake_directory_internal
= intern ("make-directory-internal");
5183 Qdelete_directory
= intern ("delete-directory");
5184 Qdelete_file
= intern ("delete-file");
5185 Qrename_file
= intern ("rename-file");
5186 Qadd_name_to_file
= intern ("add-name-to-file");
5187 Qmake_symbolic_link
= intern ("make-symbolic-link");
5188 Qfile_exists_p
= intern ("file-exists-p");
5189 Qfile_executable_p
= intern ("file-executable-p");
5190 Qfile_readable_p
= intern ("file-readable-p");
5191 Qfile_writable_p
= intern ("file-writable-p");
5192 Qfile_symlink_p
= intern ("file-symlink-p");
5193 Qaccess_file
= intern ("access-file");
5194 Qfile_directory_p
= intern ("file-directory-p");
5195 Qfile_regular_p
= intern ("file-regular-p");
5196 Qfile_accessible_directory_p
= intern ("file-accessible-directory-p");
5197 Qfile_modes
= intern ("file-modes");
5198 Qset_file_modes
= intern ("set-file-modes");
5199 Qfile_newer_than_file_p
= intern ("file-newer-than-file-p");
5200 Qinsert_file_contents
= intern ("insert-file-contents");
5201 Qwrite_region
= intern ("write-region");
5202 Qverify_visited_file_modtime
= intern ("verify-visited-file-modtime");
5203 Qset_visited_file_modtime
= intern ("set-visited-file-modtime");
5205 staticpro (&Qexpand_file_name
);
5206 staticpro (&Qsubstitute_in_file_name
);
5207 staticpro (&Qdirectory_file_name
);
5208 staticpro (&Qfile_name_directory
);
5209 staticpro (&Qfile_name_nondirectory
);
5210 staticpro (&Qunhandled_file_name_directory
);
5211 staticpro (&Qfile_name_as_directory
);
5212 staticpro (&Qcopy_file
);
5213 staticpro (&Qmake_directory_internal
);
5214 staticpro (&Qdelete_directory
);
5215 staticpro (&Qdelete_file
);
5216 staticpro (&Qrename_file
);
5217 staticpro (&Qadd_name_to_file
);
5218 staticpro (&Qmake_symbolic_link
);
5219 staticpro (&Qfile_exists_p
);
5220 staticpro (&Qfile_executable_p
);
5221 staticpro (&Qfile_readable_p
);
5222 staticpro (&Qfile_writable_p
);
5223 staticpro (&Qaccess_file
);
5224 staticpro (&Qfile_symlink_p
);
5225 staticpro (&Qfile_directory_p
);
5226 staticpro (&Qfile_regular_p
);
5227 staticpro (&Qfile_accessible_directory_p
);
5228 staticpro (&Qfile_modes
);
5229 staticpro (&Qset_file_modes
);
5230 staticpro (&Qfile_newer_than_file_p
);
5231 staticpro (&Qinsert_file_contents
);
5232 staticpro (&Qwrite_region
);
5233 staticpro (&Qverify_visited_file_modtime
);
5234 staticpro (&Qset_visited_file_modtime
);
5236 Qfile_name_history
= intern ("file-name-history");
5237 Fset (Qfile_name_history
, Qnil
);
5238 staticpro (&Qfile_name_history
);
5240 Qfile_error
= intern ("file-error");
5241 staticpro (&Qfile_error
);
5242 Qfile_already_exists
= intern ("file-already-exists");
5243 staticpro (&Qfile_already_exists
);
5244 Qfile_date_error
= intern ("file-date-error");
5245 staticpro (&Qfile_date_error
);
5248 Qfind_buffer_file_type
= intern ("find-buffer-file-type");
5249 staticpro (&Qfind_buffer_file_type
);
5252 DEFVAR_LISP ("file-name-coding-system", &Vfile_name_coding_system
,
5253 "*Coding system for encoding file names.\n\
5254 If it is nil, default-file-name-coding-system (which see) is used.");
5255 Vfile_name_coding_system
= Qnil
;
5257 DEFVAR_LISP ("default-file-name-coding-system",
5258 &Vdefault_file_name_coding_system
,
5259 "Default coding system for encoding file names.\n\
5260 This variable is used only when file-name-coding-system is nil.\n\
5262 This variable is set/changed by the command set-language-environment.\n\
5263 User should not set this variable manually,\n\
5264 instead use file-name-coding-system to get a constant encoding\n\
5265 of file names regardless of the current language environment.");
5266 Vdefault_file_name_coding_system
= Qnil
;
5268 DEFVAR_LISP ("auto-save-file-format", &Vauto_save_file_format
,
5269 "*Format in which to write auto-save files.\n\
5270 Should be a list of symbols naming formats that are defined in `format-alist'.\n\
5271 If it is t, which is the default, auto-save files are written in the\n\
5272 same format as a regular save would use.");
5273 Vauto_save_file_format
= Qt
;
5275 Qformat_decode
= intern ("format-decode");
5276 staticpro (&Qformat_decode
);
5277 Qformat_annotate_function
= intern ("format-annotate-function");
5278 staticpro (&Qformat_annotate_function
);
5280 Qcar_less_than_car
= intern ("car-less-than-car");
5281 staticpro (&Qcar_less_than_car
);
5283 Fput (Qfile_error
, Qerror_conditions
,
5284 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
)));
5285 Fput (Qfile_error
, Qerror_message
,
5286 build_string ("File error"));
5288 Fput (Qfile_already_exists
, Qerror_conditions
,
5289 Fcons (Qfile_already_exists
,
5290 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
5291 Fput (Qfile_already_exists
, Qerror_message
,
5292 build_string ("File already exists"));
5294 Fput (Qfile_date_error
, Qerror_conditions
,
5295 Fcons (Qfile_date_error
,
5296 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
5297 Fput (Qfile_date_error
, Qerror_message
,
5298 build_string ("Cannot set file date"));
5300 DEFVAR_BOOL ("insert-default-directory", &insert_default_directory
,
5301 "*Non-nil means when reading a filename start with default dir in minibuffer.");
5302 insert_default_directory
= 1;
5304 DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm
,
5305 "*Non-nil means write new files with record format `stmlf'.\n\
5306 nil means use format `var'. This variable is meaningful only on VMS.");
5307 vms_stmlf_recfm
= 0;
5309 DEFVAR_LISP ("directory-sep-char", &Vdirectory_sep_char
,
5310 "Directory separator character for built-in functions that return file names.\n\
5311 The value should be either ?/ or ?\\ (any other value is treated as ?\\).\n\
5312 This variable affects the built-in functions only on Windows,\n\
5313 on other platforms, it is initialized so that Lisp code can find out\n\
5314 what the normal separator is.");
5315 XSETFASTINT (Vdirectory_sep_char
, '/');
5317 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist
,
5318 "*Alist of elements (REGEXP . HANDLER) for file names handled specially.\n\
5319 If a file name matches REGEXP, then all I/O on that file is done by calling\n\
5322 The first argument given to HANDLER is the name of the I/O primitive\n\
5323 to be handled; the remaining arguments are the arguments that were\n\
5324 passed to that primitive. For example, if you do\n\
5325 (file-exists-p FILENAME)\n\
5326 and FILENAME is handled by HANDLER, then HANDLER is called like this:\n\
5327 (funcall HANDLER 'file-exists-p FILENAME)\n\
5328 The function `find-file-name-handler' checks this list for a handler\n\
5329 for its argument.");
5330 Vfile_name_handler_alist
= Qnil
;
5332 DEFVAR_LISP ("set-auto-coding-function",
5333 &Vset_auto_coding_function
,
5334 "If non-nil, a function to call to decide a coding system of file.\n\
5335 One argument is passed to this function: the string of concatination\n\
5336 or the heading 1K-byte and the tailing 3K-byte of a file to be read.\n\
5337 This function should return a coding system to decode the file contents\n\
5338 specified in the heading lines with the format:\n\
5339 -*- ... coding: CODING-SYSTEM; ... -*-\n\
5340 or local variable spec of the tailing lines with `coding:' tag.");
5341 Vset_auto_coding_function
= Qnil
;
5343 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions
,
5344 "A list of functions to be called at the end of `insert-file-contents'.\n\
5345 Each is passed one argument, the number of bytes inserted. It should return\n\
5346 the new byte count, and leave point the same. If `insert-file-contents' is\n\
5347 intercepted by a handler from `file-name-handler-alist', that handler is\n\
5348 responsible for calling the after-insert-file-functions if appropriate.");
5349 Vafter_insert_file_functions
= Qnil
;
5351 DEFVAR_LISP ("write-region-annotate-functions", &Vwrite_region_annotate_functions
,
5352 "A list of functions to be called at the start of `write-region'.\n\
5353 Each is passed two arguments, START and END as for `write-region'.\n\
5354 These are usually two numbers but not always; see the documentation\n\
5355 for `write-region'. The function should return a list of pairs\n\
5356 of the form (POSITION . STRING), consisting of strings to be effectively\n\
5357 inserted at the specified positions of the file being written (1 means to\n\
5358 insert before the first byte written). The POSITIONs must be sorted into\n\
5359 increasing order. If there are several functions in the list, the several\n\
5360 lists are merged destructively.");
5361 Vwrite_region_annotate_functions
= Qnil
;
5363 DEFVAR_LISP ("write-region-annotations-so-far",
5364 &Vwrite_region_annotations_so_far
,
5365 "When an annotation function is called, this holds the previous annotations.\n\
5366 These are the annotations made by other annotation functions\n\
5367 that were already called. See also `write-region-annotate-functions'.");
5368 Vwrite_region_annotations_so_far
= Qnil
;
5370 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers
,
5371 "A list of file name handlers that temporarily should not be used.\n\
5372 This applies only to the operation `inhibit-file-name-operation'.");
5373 Vinhibit_file_name_handlers
= Qnil
;
5375 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation
,
5376 "The operation for which `inhibit-file-name-handlers' is applicable.");
5377 Vinhibit_file_name_operation
= Qnil
;
5379 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name
,
5380 "File name in which we write a list of all auto save file names.\n\
5381 This variable is initialized automatically from `auto-save-list-file-prefix'\n\
5382 shortly after Emacs reads your `.emacs' file, if you have not yet given it\n\
5384 Vauto_save_list_file_name
= Qnil
;
5386 defsubr (&Sfind_file_name_handler
);
5387 defsubr (&Sfile_name_directory
);
5388 defsubr (&Sfile_name_nondirectory
);
5389 defsubr (&Sunhandled_file_name_directory
);
5390 defsubr (&Sfile_name_as_directory
);
5391 defsubr (&Sdirectory_file_name
);
5392 defsubr (&Smake_temp_name
);
5393 defsubr (&Sexpand_file_name
);
5394 defsubr (&Ssubstitute_in_file_name
);
5395 defsubr (&Scopy_file
);
5396 defsubr (&Smake_directory_internal
);
5397 defsubr (&Sdelete_directory
);
5398 defsubr (&Sdelete_file
);
5399 defsubr (&Srename_file
);
5400 defsubr (&Sadd_name_to_file
);
5402 defsubr (&Smake_symbolic_link
);
5403 #endif /* S_IFLNK */
5405 defsubr (&Sdefine_logical_name
);
5408 defsubr (&Ssysnetunam
);
5409 #endif /* HPUX_NET */
5410 defsubr (&Sfile_name_absolute_p
);
5411 defsubr (&Sfile_exists_p
);
5412 defsubr (&Sfile_executable_p
);
5413 defsubr (&Sfile_readable_p
);
5414 defsubr (&Sfile_writable_p
);
5415 defsubr (&Saccess_file
);
5416 defsubr (&Sfile_symlink_p
);
5417 defsubr (&Sfile_directory_p
);
5418 defsubr (&Sfile_accessible_directory_p
);
5419 defsubr (&Sfile_regular_p
);
5420 defsubr (&Sfile_modes
);
5421 defsubr (&Sset_file_modes
);
5422 defsubr (&Sset_default_file_modes
);
5423 defsubr (&Sdefault_file_modes
);
5424 defsubr (&Sfile_newer_than_file_p
);
5425 defsubr (&Sinsert_file_contents
);
5426 defsubr (&Swrite_region
);
5427 defsubr (&Scar_less_than_car
);
5428 defsubr (&Sverify_visited_file_modtime
);
5429 defsubr (&Sclear_visited_file_modtime
);
5430 defsubr (&Svisited_file_modtime
);
5431 defsubr (&Sset_visited_file_modtime
);
5432 defsubr (&Sdo_auto_save
);
5433 defsubr (&Sset_buffer_auto_saved
);
5434 defsubr (&Sclear_buffer_auto_save_failure
);
5435 defsubr (&Srecent_auto_save_p
);
5437 defsubr (&Sread_file_name_internal
);
5438 defsubr (&Sread_file_name
);
5441 defsubr (&Sunix_sync
);